(* =================== *) (* SECTION 13 -- INDEXED SUMS, EXPANSION AND EXTENSION *) leftExpand[a_. + b_. sum[n_, nlo_, nhi_][s_]] := leftExpand[1][a + b sum[n, nlo, nhi][s]] leftExpand[q_Integer][a_. + b_. sum[n_, nlo_, nhi_][s_]] /; nlo =!= -infinity := a + b * sum[n, nlo+q, nhi][s] + b * ( Thread[n -> nlo + Range[q] -1] // pipe[map[replaceUsing] , map[supply[s]], apply[Plus]]) leftExpand[q_Integer][a_. + b_. sum[n_, -infinity, nhi_][s_]]:= a + b * sum[n, -infinity, nhi][s] leftExtend[a_. + b_. sum[n_, nlo_, nhi_][s_]] := leftExtend[1][a + b sum[n, nlo, nhi][s]] leftExtend[q_Integer][a_. + b_. sum[n_, nlo_, nhi_][s_]] /; nlo =!= -infinity := a + b * sum[n, nlo-q, nhi][s] - b * (Thread[n -> nlo - Range[q]] // pipe[map[replaceUsing] , map[supply[s]], apply[Plus]]) leftExtend[q_Integer][a_. + b_. sum[n_, -infinity, nhi_][s_]]:= a + b * sum[n, -infinity, nhi][s] rightExpand[a_. + b_. sum[n_, nlo_, nhi_][s_]] := rightExpand[1][a + b sum[n, nlo, nhi][s]] rightExpand[q_Integer][a_. + b_. sum[n_, nlo_, nhi_][s_]] /; nhi =!= infinity := a + b * sum[n, nlo, nhi - q][s] + b * (Thread[n -> nhi - Range[q] + 1] // pipe[map[replaceUsing] , map[supply[s]], apply[Plus]]) rightExpand[q_Integer][a + b * sum[n_, nlo_, infinity][s_]] := a + b * sum[n, nlo, infinity][s] rightExtend[a_. + b_. sum[n_, nlo_, nhi_][s_]] := rightExtend[1][a + b sum[n, nlo, nhi][s]] rightExtend[q_Integer][a_. + b_. sum[n_, nlo_, nhi_][s_]] /; nhi =!= infinity := a + b sum[n, nlo, nhi + q][s] - b * (Thread[n -> nhi + Range[q]] // pipe[map[replaceUsing] , map[supply[s]], apply[Plus]]) rightExtend[q_Integer][a_. + b_. sum[n_, nlo_, infinity][s_]] := a + b sum[n, nlo, infinity][s] fullExpand[a_. + b_. sum[n_, nlo_, nhi_][s_]] /; IntegerQ[nhi-nlo] := a + b Sum[s, {n, nlo, nhi}] fullExpand[a_. + b_. sum[n_, nlo_, nhi_][s_]] /; !IntegerQ[nhi-nlo] := a + b sum[n, nlo, nhi][s] cleanup[expandAndExtend] = {leftExpand[q_][s_] :> s, leftExpand[s_] :> s, leftExtend[q_][s_] :> s, leftExtend[s_] :> s, rightExpand[q_][s_] :> s, rightExpand[s_] :> s, rightExtend[q_][s_] :> s, rightExtend[s_] :> s} (* ======================= *) (* SECTION 14 -- INDEXED PRODUCTS, EXPANSION AND EXTENSION *) leftExpand[a_. + b_. prod[n_, nlo_, nhi_][s_]] := leftExpand[1][a + b prod[n, nlo, nhi][s]] leftExpand[q_Integer][a_. + b_. prod[n_, nlo_, nhi_][s_]] /; nlo =!= -infinity := a + b * prod[n, nlo+q, nhi][s] * (Thread[n -> nlo + Range[q] -1] // pipe[map[replaceUsing] , map[supply[s]], apply[Times]]) leftExpand[q_Integer][a_. + b_. prod[n_, -infinity, nhi_][s_]]:= a + b * prod[n, -infinity, nhi][s] leftExtend[a_. + b_. prod[n_, nlo_, nhi_][s_]] := leftExtend[1][a + b prod[n, nlo, nhi][s]] leftExtend[q_Integer][a_. + b_. prod[n_, nlo_, nhi_][s_]] /; nlo =!= -infinity := a + b * prod[n, nlo-q, nhi][s] / (Thread[n -> nlo + Range[q] -1] // pipe[map[replaceUsing] , map[supply[s]], apply[Times]]) leftExtend[q_Integer][a_. + b_. prod[n_, -infinity, nhi_][s_]]:= a + b * prod[n, -infinity, nhi][s] rightExpand[a_. + b_. prod[n_, nlo_, nhi_][s_]] := leftExpand[1][a + b prod[n, nlo, nhi][s]] rightExpand[q_Integer][a_. + b_. prod[n_, nlo_, nhi_][s_]] /; nlo =!= infinity := a + b * prod[n, nlo, nhi - q][s] * (Thread[n -> nhi - Range[q] + 1] // pipe[map[replaceUsing] , map[supply[s]], apply[Times]]) rightExpand[prod[n_, nlo_, infinity][s_]] := prod[n, nlo, infinity][s] rightExpand[q_Integer][a + b * prod[n_, nlo_, infinity][s_]] := a + b * prod[n, nlo, infinity][s] rightExtend[a_. + b_. prod[n_, nlo_, nhi_][s_]] := rightExtend[1][a + b prod[n, nlo, nhi][s]] rightExtend[q_Integer][a_. + b_. prod[n_, nlo_, nhi_][s_]] /; nhi =!= infinity := a + b * prod[n, nlo, nhi + q][s] / (Thread[n -> nhi + Range[q]] // pipe[map[replaceUsing] , map[supply[s]], apply[Times]]) rightExtend[q_Integer][a_. + b_. prod[n_, nlo_, infinity][s_]] := a + b prod[n, nlo, infinity][s] fullExpand[a_. + b_. prod[n_, nlo_, nhi_][s_]] /; IntegerQ[nhi-nlo] := a + b Product[s, {n, nlo, nhi}] fullExpand[a_. + b_. prod[n_, nlo_, nhi_][s_]] /; !IntegerQ[nhi-nlo] := a + b prod[n, nlo, nhi][s] (* ====================== *) (* SECTION 15 -- SUMS, PRODUCTS, INTEGRALS: REINDEXING, JOINING, SPLITTING *) reindex[newIndex_, oldIndex_ + shift_Integer][sum[oldIndex_, lo_, hi_][s_]] := sum[newIndex, lo + shift, hi + shift][s /. oldIndex -> newIndex -shift] /. {infinity + _Integer -> infinity, -infinity + _Integer -> -infinity} reindex[newIndex_, oldIndex_ + shift_Integer, newlo_, newhi_][sum[oldIndex_, lo_, hi_][s_]] := Module[{(* step, loShift, hiShift*)}, step[1] = reindex[newIndex, oldIndex + shift][sum[oldIndex, lo, hi][s]]; loShift = newlo - step[1][[0, 2]]; hiShift = newhi - step[1][[0, 3]]; step[2] = Switch[Sign[loShift], -1, leftExtend[-loShift], 0, Identity, 1, leftExpand[loShift]][step[1]]; step[3] = Switch[Sign[hiShift], -1, rightExpand[-hiShift], 0, Identity, 1, rightExtend[hiShift]][step[2]]; Return[step[3]]] reindex[newIndex_, oldIndex_ + shift_Integer][prod[oldIndex_, lo_, hi_][s_]] := prod[newIndex, lo + shift, hi + shift][s /. oldIndex -> newIndex -shift] /. {infinity + _Integer -> infinity, -infinity + _Integer -> -infinity} reindex[newIndex_, oldIndex_ + shift_Integer, newlo_, newhi_][prod[oldIndex_, lo_, hi_][s_]] := Module[{step, loShift, hiShift}, step[1] = reindex[newIndex, oldIndex + shift][prod[oldIndex, lo, hi][s]]; loShift = newlo - step[1][[0, 2]]; hiShift = newhi - step[1][[0, 3]]; step[2] = Switch[Sign[loShift], -1, leftExtend[-loShift], 0, Identity, 1, leftExpand[loShift]][step[1]]; step[3] = Switch[Sign[hiShift], -1, rightExpand[-hiShift], 0, Identity, 1, rightExtend[hiShift]][step[2]]; Return[step[3]]] grule[joinTheSummands] = c1_. sum[n_, nlo_, nhi_][s1_] + c2_. sum[n_, nlo_, nhi_][s2_] + rest_. :> sum[n, nlo, nhi][c1 s1 + c2 s2] + rest joinTheSummands[s_] := s //. grule[joinTheSummands] grule[joinTheProductands] = rest_. prod[n_, nlo_, nhi_][s1_] * prod[n_, nlo_, nhi_][s2_] :> rest * prod[n, nlo, nhi][s1 * s2] joinTheProductands[s_] := s //. grule[joinTheProductands] grule[joinTheIntegrands] = c1_. integral[v__][s1_] + c2_. integral[v__][s2_] + rest_. :> integral[v][c1 s1 + c2 s2] + rest joinTheIntegrands[s_] := s //. grule[joinTheIntegrands] grule[joinTheRanges] = {c_. sum[n_, nlo1_, nhi1_][s_] + c_. sum[n_, nlo2_, nhi2_][s_] + rest_. /; nlo2-nhi1 == 1 :> c sum[n, nlo1, nhi2][s] + rest, c_. integral[x_, xlo1_, xhi1_][s_] + c_. integral[x_, xhi1_, xhi2_][s_] + rest_. :> c sum[x, xlo1, xhi2][s] + rest, prod[n_, nlo1_, nhi1_][s_] * prod[n_, nlo2_, nhi2_][s_] * rest_ /; nlo2-nhi1 == 1:> prod[n, nlo1, nhi2][s] * rest} joinTheRanges[s_] := s //. grule[joinTheRanges] splitTheRange[ns_][a_. + b_. sum[n_, nlo_, nhi_][s_]] := If[ IntegerQ[Expand[ns] - nlo] && IntegerQ[nhi - Expand[ns]] && ns - nlo >= 0 && nhi - ns >= 0 || is[Symbol][ns], a + b sum[n, nlo, Expand[ns][s] + b sum[n, Expand[ns+1], nhi][s], a + b sum[n, nlo, nhi][s]]] splitTheRange[ns_][prod[n_, nlo_, nhi_][s_]] := If[ IntegerQ[Expand[ns] - nlo] && IntegerQ[nhi - Expand[ns]] && ns - nlo >= 0 && nhi - ns >= 0 || is[Symbol][ns], prod[n, nlo, Expand[ns][s] * prod[n, Expand[ns+1], nhi][s], prod[n, nlo, nhi][s]]] splitTheRange[xs_][a_. + b_. integral[x_, xlo_, xhi_][s_]] := a + b integral[x, xlo, Expand[xs]][s] + b integral[x, Expand[xs], xhi][s] sum[i__][s_] // expandAndDistribute := Distribute[sum[i][s // Expand]] integral[i__][s_] // expandAndDistribute := Distribute[integral[i][s // Expand]] (* =============================== *) (* SECTION 16 -- MOVING MULTIPLIERS IN LINEAR OPERATORS *) (* See explanation in typeset account *) grule[moveMultiplierIntoSum] = a_. + b_. sum[n_, lims___][s_] :> a + sum[n, lims][b s] moveMultiplierIntoSum[t_] := t /. grule[moveMultiplierIntoSum] moveMultipliersIntoNestedSum[s_] := fixedPoint[mapAll[replaceUsing[grule[moveMultiplierIntoSum]]]][s] moveMultiplierOutOfSum[a_. + b_. sum[n_, lims___][s_] ] := a + b * select[doesNotContain[n]][Hold[1] * s] * sum[n, lims][ select[contains[n]][Hold[1] * s]] // ReleaseHold grule[moveMultiplierOutOfSum] = sum[n_, lims___][s_] :> moveMultiplierOutOfSum[sum[n, lims][s]] moveMultipliersOutOfNestedSum[s_] := fixedPoint[mapAll[replaceUsing[grule[moveMultiplierOutOfSum]]]][s] (* Correspondingly *) grule[moveMultiplierIntoIntegral] = a_. + b_. integral[x_, lims___][s_] :> a + integral[x, lims][b s] moveMultiplierIntoIntegral[t_] := t /. grule[moveMultiplierIntoIntegral] grule[moveMultiplierIntoIntegral] = a_. + b_. volumeIntegral[V_][s_] :> a + volumeIntegral[V][b s] moveMultiplierIntoVolumeIntegral[t_] := t /. grule[moveMultiplierIntoVolumeIntegral] moveMultipliersIntoNestedIntegral[s_] := fixedPoint[mapAll[replaceUsing[grule[moveMultiplierIntoIntegral]]]][s] moveMultipliersIntoNestedIntegral[s_] := fixedPoint[mapAll[replaceUsing[grule[moveMultiplierIntoIntegral]]]][s] (* for backwards compatibility *) moveMultiplierOutOfIntegral[integral[x_, lims___][s_]] := select[notContaining[x]][Hold[1] * s] * integral[x, lims][ select[containing[x]][Hold[1] * s]] // ReleaseHold grule[moveMultiplierOutOfIntegral] = integral[x_, lims___][s_] :> moveMultiplierOutOfIntegral[integral[x, lims][s]] moveMultiplierOutOfVolumeIntegral[volumeIntegral[V_][s_]] := select[notContaining[V]][Hold[1] * s] * volumeIntegral[V][ select[containing[V]][Hold[1] * s]] // ReleaseHold grule[moveMultiplierOutOfVolumeIntegral] = volumeIntegral[V_][s_] :> moveMultiplierOutOfVolumeIntegral[volumeIntegral[V][s]] moveMultipliersOutOfNestedIntegral[s_] := fixedPoint[mapAll[replaceUsing[grule[moveMultiplierOutOfIntegral]]]][s] grule[moveMultiplierIntoLimit] = a_. + b_. limit[x_ -> z_][s_] :> a + limit[x -> z][b s] moveMultiplierIntoLimit[t_] := t /. grule[moveMultiplierIntoLimit] moveMultiplierOutOfLimit[a_. + b_. limit[x_ -> z_][s_]] := a + b * select[notContaining[x]][Hold[1] * s] * limit[x -> z][select[containing[x]][Hold[1] * s]] // ReleaseHold grule[moveMultiplierOutOfLimit] = limit[x_ -> z_][s_] :> moveMultiplierOutOfLimit[limit[x, lim][s]] moveMultipliersOutOfNestedLimit[s_] := s //. grule[moveMultiplierOutOfLimit] grule[moveMultiplierIntoDerivative] = a_. + b_. D$[x__][s_] :> a + D$[x][b s] moveMultiplierIntoDerivative[t_] := t /. grule[moveMultiplierIntoDerivative] moveMultipliersIntoNestedDerivative[s_] := fixedPoint[mapAll[replaceUsing[grule[moveMultiplierIntoDerivative]]]][s] variablesOfDifferentiationIn[x__] := Join[{x} // pipe[select[is[List]], map[First]], {x} // select[is[Symbol]]] moveMultiplierOutOfDerivative[a_. + b_. D$[x__][s_]] := a + b * select[notContainingAny[variablesOfDifferentiationIn[x]]][Hold[1] * s] * D$[x][select[containingAny[variablesOfDifferentiationIn[x]]][Hold[1] * s]] // ReleaseHold grule[moveMultiplierOutOfDerivative] = D$[x__][s_] :> moveMultiplierOutOfDerivative[D$[x][s]] moveMultipliersOutOfNestedDerivative[s_] := s //. grule[moveMultiplierOutOfDerivative] (* Combining *) moveMultipliersIntoNest[s_] := FixedPoint[ MapAll[ # /. {grule[moveMultiplierIntoSum], grule[moveMultiplierIntoIntegral], grule[moveMultiplierIntoLimit], grule[moveMultiplierIntoDerivative]}&, #]&, s] moveMultipliersOutOfNest[s_] := FixedPoint[ MapAll[# /. {grule[moveMultiplierOutOfSum], grule[moveMultiplierOutOfIntegral], grule[moveMultiplierOutOfLimit], grule[moveMultiplierOutOfDerivative]}&, #]&, s] moveMultiplierRight[s_] := s /. {grule[moveMultiplierIntoSum], grule[moveMultiplierIntoIntegral], grule[moveMultiplierIntoLimit], grule[moveMultiplierIntoDerivative]} moveMultiplierLeft[s_] := s /. {grule[moveMultiplierOutOfSum], grule[moveMultiplierOutOfIntegral], grule[moveMultiplierOutOfLimit], grule[moveMultiplierOutOfDerivative]} (* for backwards compatibility *) moveConstantRight = moveCoefficientRight = moveMultiplierRight moveConstantLeft = moveCoefficientLeft = moveMultiplierLeft (* =========================== *) (* SECTION 17 -- COMMUTATION *) grule[commuteSumSum] = a_. + b_. sum[n1_, lo1_, hi1_][sum[n2_, lo2_, hi2_][s_]] /; {lo2, hi2} // pipe[map[notContaining[n1]], apply[And]] :> a + b sum[n2, lo2, hi2][sum[n1, lo1, hi1][s]] commuteSumSum[s_] := s /. grule[commuteSumSum] grule[commuteSumIntegral] = a_. + b_. sum[n_, lo_, hi_][integral[x_, xlo_, xhi_][s_]] /; {xlo, xhi} // pipe[map[notContaining[n]], apply[And]] :> a+ b integral[x, xlo, xhi][sum[n, nlo, nhi][s]] commuteSumIntegral[s_] := s /. grule[commuteSumIntegral] grule[commuteIntegralIntegral] = a_. + b_. integral[x1_, x1lo_, x1hi_][ integral[x2_, x2lo_, x2hi_][s_]] /; {xlo2, xhi2} // pipe[map[notContaining[x1]], apply[And]] :> a+ b integral[x2, x2lo, x2hi][integral[x1, x1lo, x1hi][s]] commuteIntegralIntegral[s_] := s /. grule[commuteIntegralIntegral] grule[commuteIntegralSum] = (a_. + b_. integral[x_, xlo_, xhi_][sum[n_, lo_, hi_][s_]] /; ( {lo, hi} // pipe[map[notContaining[x]] , apply[And]] )) :> a + b sum[n, lo, hi][integral[x, xlo, xhi][s]] commuteIntegralSum[s_] := s /. grule[commuteIntegralSum] grule[commuteVolumeIntegralSum] = (a_. + b_. volumeIntegral[V__][sum[n_, lo_, hi_][s_]] /; ( {lo, hi} // pipe[map[notContaining[V]] , apply[And]] )) :> a + b sum[n, lo, hi][volumeIntegral[V][s]] commuteVolumeIntegralSum[s_] := s /. grule[commuteVolumeIntegralSum] grule[commuteD$Integral] = a_. + b_. D$[x__][ integral[x2_, x2lo_, x2hi_][s_]] /; ({x2lo, x2hi} // pipe[map[notContainingAny[variablesOfDifferentiationIn[x]]], apply[And]]) :> a+ b integral[x2, x2lo, x2hi][D$[x][s]] commuteD$Integral[s_] := s /. grule[commuteD$Integral] grule[commuteD$Sum] = a_. + b_. D$[x__][ sum[n_, nlo_, nhi_][s_]] /; ({nlo, nhi} // pipe[map[notContainingAny[variablesOfDifferentiationIn[x]]], apply[And]]) :> a+ b sum[n, nlo, nhi][D$[x][s]] commuteD$Sum[s_] := s /. grule[commuteD$Sum] (* for backward compatibility *) commuteD$integral =commuteD$Integral commuteD$sum =commuteD$Sum (* =========================== *) (* SECTION 18 -- DISTRIBUTION, FACTORING AND COLLECTION *) distribution[mCursors_List][tCursors_List][pCursor_Integer][s_Times] /; distributionDataQ[mCursors][tCursors][pCursor][s] := Module[{(* innerMultiplier, outerMultiplier, targetTerms, nonTargetTerms, result *)}, innerMultiplier = s[[mCursors]]; outerMultiplier = s[[Complement[Range[Length[s]], Append[mCursors, pCursor]]]]; targetTerms = s[[pCursor, tCursors]]; nonTargetTerms = s[[pCursor]] - targetTerms; result = outerMultiplier * (innerMultiplier * nonTargetTerms + (targetTerms // pipe[plus[Hold[0]], apply[List], map[times[innerMultiplier]], apply[Plus], ReleaseHold])) ; (* plus[Hold[0]] needed in case targetTerms is just a single term*) Return[result]] distributionDataQ[mCursors_List][tCursors_List][pCursor_Integer][s_Times] := 0 < Length[mCursors] < Length[s] && 0 < pCursor <= Length[s] && Head[s[[pCursor]]] === Plus && 0 < Length[tCursors] <= Length[s[[pCursor]]] && Max[Abs[mCursors]] <= Length[s] && Max[Abs[tCursors]] <= Length[s[[pCursor]]] distribution[][][pCursor_][s_Times] := distribution[ DeleteCases[Range[Length[s]], pCursor] ] [ Range[Length[s[[pCursor]]]] ][pCursor][s] distribution[mCursors_List][][pCursor_][s_Times] := distribution[mCursors][Range[Length[s[[pCursor]]]]][pCursor][s] distribution[][tCursors_List][pCursor_][s_Times] := distribution[DeleteCases[Range[Length[s]], pCursor]][tCursors][pCursor][s] distribution[mCursors_List][tCursors_List][pCursor_Integer][s_] /; Not[distributionDataQ[mCursors][tCursors][pCursor][s]] := s distribution[mCursor__Integer] := distribution[{mCursor}] distribution[mc___][tCursor__Integer] := distribution[mc][{tCursor}] factorOut[x_][s_Plus] /; x != -1 := x * (#/x & /@ s) factorOut[x_][s_] /; Head[s] =!= Plus && x != -1 := s factorOut[-1][s_Plus] := -HoldForm @@ {-s} factorOut[-1][a_ s_Plus] := -a Hold[-s] // ReleaseHold factorOut[-1][s_] /; Not[MatchQ[s, a_. b_Plus | _Rational]] := s factorOut[-1][s_Rational] := HoldForm[-1] * (-s) (* collect[v__][s_] see unary functions *) collectByArguments[f_][s_] := Collect[s, s // pipe[instancesOf[f[_]], Union]] (* ============================================= *) Print["part02 loaded"]