matrixEDCcode

version 3.6.0 - May 2007

To start a new set of calculations, just re-evaluate this notebook without first quitting the kernel. All symbols defined previously and all In/Out lines will be cleared, though memory used will not be recovered.

Off[General::"spell", General::"spell1", Remove::"rmnsm", 
      UpSet::"write"];

Unprotect["Global`*"]; ClearAll["Global`*"]; 
    Remove["Global`*"]; Unprotect[In, Out]; Clear[In, Out]; 
    Protect[In, Out]; $Line = 0; $RecursionLimit = 256; $IterationLimit = 
      4096;

Forms[i_] := {}; AllScalForms = {}; matForms[i_] := {}; 
    AllMatForms = {}; AllDifForms = {}; AllMatrices = {}; AllSymbols = {}; 
    FormVars = {_Wedge, _d}; ZeroVars = {_Wedge, _tr}; HeadList = {}; 
    ScalHeadList = {}; MatFormHeadList = {}; ZeroHeads = {}; 
    AllMatHeads = {}; 
    nodHeads = {tr, Bar, Pattern, Condition, RuleDelayed, 
        SeriesData}; $EDCversion = 360;

zeroQ[0] = True; zeroQ[x_List] := And@@(zeroQ/@Union[Flatten[x]]); 
    zeroQ[x_SeriesData] := If[x[[3]] === {}, True, False]; 
    zeroQ[x_] := False;

SetAttributes[Bar, {Listable}]; Bar[Bar[x_]] = x; 
    Bar[Complex[u_, v_]] := Complex[u, -v]; 
    Bar[x_Plus | x_Times | x_Wedge | x_Power | x_Rule | x_Equal] := Bar/@x; 
    Bar[x_SeriesData] := 
      x /. {First[x] -> Bar[First[x]], x[[2]] -> Bar[x[[2]]], 
          x[[3]] -> Bar/@x[[3]]}; 
    Bar[DirectedInfinity[x_]] := DirectedInfinity[Bar[x]]; 
    Bar[HoldPattern[tr[x_]]] := tr[Bar[x]]; Bar[d[x_]] := d[Bar[x]]; 
    Bar[Derivative[x__][y_][z__]] := 
      If[Union[Bar[{z}]] === Union[{z}], 
        Derivative[
              Sequence@@
                Permutations[{x}][
                  [Position[Permutations[{z}], Bar[{z}]][[1, 1]]]
                    ]][Bar[y]][z], 
        Derivative[x][Bar[y]][Sequence@@Bar[{z}]]]; 
    Bar[x_] := x /; NumericQ[x];

Qvalue[x_List] := 
      Length[Select[
          OrderedQ/@Transpose[{Drop[x, -1], Rest[x]}], # === False&]]

AllCaseTable[x_List] := 
      With[{rvstr = Reverse[Map[Transpose, x] /. -u_ -> u]}, 
        If[traceOption === 2, 
          Join[Table[{Qvalue[RotateLeft[x, i]], RotateLeft[x, i], i}, {i, 0, 
                Length[x] - 1}], 
            Table[{Qvalue[RotateRight[rvstr, i]], RotateRight[rvstr, i], 
                -i - 1}, {i, 0, Length[x] - 1}]], 
          Table[{Qvalue[RotateLeft[x, i]], RotateLeft[x, i], i}, {i, 0, 
              Length[x] - 1}]]]

bestOrd[x_List] := 
      Block[{tmp = Sort[AllCaseTable[x]]}, 
        tmp = Select[tmp, First[#1] === tmp[[1, 1]]&]; 
        If[Length[tmp] > 1, 
          First[Sort[Select[tmp, #1[[2]] === tmp[[1, 2]]&], 
              Abs[Last[#1]] < Abs[Last[#2]]&]], First[tmp]]];

splitFDprod[m_, FDx_List] := 
      (Plus@@Take[FDx, m]) (Plus@@Drop[FDx, m]); 
    allFDprods[FDx_List] := 
      Sum[FDx[[i]]*(Plus@@Drop[FDx, i]), {i, Length[FDx] - 1}];

traceOption = 2; 
    tr[x_] := reWrite[Sum[x[[i, i]], {i, Length[x]}]] /; MatrixQ[x]; 
    tr[x_Plus] := tr/@x; 
    tr[x_SeriesData] := 
      (x /. x[[3]] -> tr/@x[[3]]) + 
        (x /. x[[3]] -> {}); 
    tr[x__ y_] := (x tr[y]) /; ! MatQ[x]; tr[d[x_]] := d[tr[x]]; 
    tr[x__⋀y__] := (x⋀tr[Wedge[y]]) /; ScalFormQ[x]; 
    tr[x_] := (tr[x] = 0) /; AntisymQ[x]; 
    tr[Bar[x_]] := 
      With[{evalHx = tr[x]}, Bar[evalHx] /; Head[evalHx] =!= tr]; 
    tr[x_Wedge /; Union[Head/@Level[x, 1]] === {Bar}] := 
      With[{evalHx = tr[Bar/@x]}, Bar[evalHx] /; Head[evalHx] =!= tr]; 
    tr[x_Wedge] := 
      Block[{inpList = List@@x, resList, FDx}, resList = bestOrd[inpList]; 
          FDx = FormDegree/@inpList; 
          Which[ Last[resList] > 0, 
            (-1)^splitFDprod[ Last[resList], FDx] 
              tr[Wedge@@resList[[2]]],  Last[resList] === -1, 
            (-1)^
                (allFDprods[FDx] + Length[Select[inpList, AntisymQ]]) 
              tr[Wedge@@resList[[2]]],  Last[resList] < -1, 
            (-1)^
                (allFDprods[FDx] + 
                    splitFDprod[Abs[1 +  Last[resList]], FDx] + 
                    Length[Select[inpList, AntisymQ]]) 
              tr[Wedge@@resList[[2]]]]] /; 
        traceOption > 0 && bestOrd[List@@x][[2]] =!= List@@x; 
    tr[x__⋀y__] := 
      (tr[x⋀y] = 0) /; 
        ((EvenQ[FormDegree[Wedge[x]]] || EvenQ[FormDegree[Wedge[y]]])
                 && (
                SymQ[Wedge[x]] && AntisymQ[Wedge[y]] || 
                  SymQ[Wedge[y]] && AntisymQ[Wedge[x]])) || 
          ((OddQ[FormDegree[Wedge[x]]] && OddQ[FormDegree[Wedge[y]]])
                 && (
                SymQ[Wedge[x]] && SymQ[Wedge[y]] || 
                  AntisymQ[Wedge[y]] && AntisymQ[Wedge[x]])); 
    tr[x_] := x matDimension /; ! MatQ[x];

toComponents[x_ + y_, rul_] := 
      toComponents[x, rul] + toComponents[y, rul]; 
    toComponents[x_.*y_, rul_] := 
      If[MatQ[x*y], reWrite[x*y /. rul], 
        reWrite[(x*y*IdentityMatrix[matDimension]) /. rul]]; 
    toComponents[x_⋀y_, rul_] := 
      If[MatQ[x⋀y], reWrite[x⋀y /. rul], 
        reWrite[(x⋀y*IdentityMatrix[matDimension]) /. rul]];

FormDegree[x_Plus] := FormDegree[First[x]]; 
    FormDegree[x_Times] := Plus@@FormDegree/@List@@x; 
    FormDegree[x_Wedge] := Plus@@FormDegree/@List@@x; 
    FormDegree[d[x_]] := FormDegree[d[x]] = 1 + FormDegree[x]; 
    FormDegree[x_List] := 
      FormDegree[First[Select[Union[Flatten[x]], ! zeroQ[#]&]]]; 
    FormDegree[tr[x_]] := FormDegree[x]; 
    FormDegree[Bar[x_]] := FormDegree[Bar[x]] = FormDegree[x]; 
    FormDegree[x_SeriesData] := 
      If[x[[3]] === {}, 0, FormDegree[x[[3]]]]; FormDegree[x_] := 0;

DeclareMatrixForms[z__] := 
      Block[{x = {{z}}, xi, rxi, h, ht, k, min1, oldHeads, newHeads}, 
        While[Head[x[[1, 1]]] === List, x = First[x]]; 
        Unprotect[Transpose]; 
        Do[xi = x[[i]]; 
          If[xi[[3]] === xi[[2]] || xi[[3]] === -xi[[2]], 
            rxi = {xi[[2]]}, rxi = Rest[xi]]; 
          matForms[First[xi]] = Union[matForms[First[xi]], rxi]; 
          
AllMatrices = Union[AllMatrices, rxi]; 
          h = Head[xi[[2]]]; 
          If[First[xi] > 0, AllMatForms = Union[AllMatForms, rxi], 
            If[h =!= Symbol, ZeroHeads = Union[{h}, ZeroHeads]; 
              If[Head[xi[[3]]] =!= Times, 
                ZeroHeads = Union[{Head[xi[[3]]]}, ZeroHeads]]]]; 
          If[h === Symbol, FormDegree[xi[[2]]] = First[xi]; 
            BasicMatQ[xi[[2]]] = True; 
            BasicScalFormQ[xi[[2]]] = False; 
            Transpose[xi[[2]]] = xi[[3]]; 
            If[xi[[3]] === -xi[[2]], tr[xi[[2]]] = 0, 
              If[xi[[3]] =!= xi[[2]], 
                FormDegree[xi[[3]]] = First[xi]; 
                BasicMatQ[xi[[3]]] = True; 
                BasicScalFormQ[xi[[3]]] = False; 
                Transpose[xi[[3]]] = xi[[2]]; 
                tr[xi[[3]]] = tr[xi[[2]]]]], 
            FormDegree[_h] = First[xi]; BasicMatQ[_h] = True; 
            BasicScalFormQ[_h] = False; ht = Head[xi[[3]]]; 
            If[ht === Times, min1 = -1; ht = h; tr[h[k_]] = 0, min1 = 1; 
              If[ht =!= h, FormDegree[_ht] = First[xi]; 
                BasicMatQ[_ht] = True; BasicScalFormQ[_ht] = False; 
                tr[ht[k_]] = tr[h[k]]]]; Transpose[h[k_]] = min1 ht[k]; 
            Transpose[ht[k_]] = min1 h[k]], {i, Length[x]}]; 
        Protect[Transpose]; 
        
AllDifForms = Union[AllScalForms, AllMatForms]; 
        AllSymbols = Union[AllDifForms, AllMatrices]; 
        MatFormHeadList = 
          Complement[Union[Head/@AllMatForms, MatFormHeadList], {Symbol}]; 
        oldHeads = AllMatHeads; 
        AllMatHeads = Union[ZeroHeads, MatFormHeadList]; 
        newHeads = Complement[AllMatHeads, oldHeads]; 
        
HeadList = Union[Head/@AllSymbols]; 
        DifFormSymbols = 
          Drop[AllDifForms, 
            -Length[Union[ScalHeadList, MatFormHeadList]]]; 
        nodHeads = Union[nodHeads, ZeroHeads]; 
        k = Thread[Blank[Union[ScalHeadList, MatFormHeadList]]]; 
        FormVars = 
          Flatten[{_Wedge, _d, Union[k, Bar[k]], 
              u_ | Bar[u_] /; MemberQ[DifFormSymbols, u], _tr}]; 
        ZeroMatSymbols = Drop[matForms[0], -Length[ZeroHeads]]; 
        ZeroVars = 
          Flatten[{_Wedge, 
              Union[Thread[Blank[ZeroHeads]], Bar[Thread[Blank[ZeroHeads]]]], 
              u_ | Bar[u_] /; MemberQ[ZeroMatSymbols, u], _tr}]; ];

DeclareForms[z__] := 
      Block[{h, x = {{z}}, xi, rxi, k, oldHeads, newHeads}, 
        While[Head[x[[1, 1]]] === List, x = First[x]]; 
        Do[xi = x[[i]]; rxi = Rest[xi]; 
          Forms[First[xi]] = Union[Forms[First[xi]], rxi]; 
          
AllScalForms = Union[AllScalForms, rxi]; 
          
Do[h = Head[rxi[[j]]]; 
            If[h === Symbol, FormDegree[rxi[[j]]] = First[xi]; 
              BasicScalFormQ[rxi[[j]]] = True; 
              BasicMatQ[rxi[[j]]] = False; , 
              FormDegree[_h] = First[xi]; BasicScalFormQ[_h] = True; 
              BasicMatQ[_h] = False; ], {j, Length[rxi]}], {i, Length[x]}]; 
        
AllDifForms = Union[AllScalForms, AllMatForms]; 
        oldHeads = ScalHeadList; 
        ScalHeadList = 
          Complement[Union[Head/@AllScalForms, ScalHeadList], {Symbol}]; 
        newHeads = Complement[ScalHeadList, oldHeads]; 
        AllSymbols = Union[AllDifForms, AllMatrices]; 
        
HeadList = Union[Head/@AllSymbols]; 
        DifFormSymbols = 
          Drop[AllDifForms, 
            -Length[Union[ScalHeadList, MatFormHeadList]]]; 
        k = Thread[Blank[Union[ScalHeadList, MatFormHeadList]]]; 
        FormVars = 
          Flatten[{_Wedge, _d, Union[k, Bar[k]], 
              u_ | Bar[u_] /; MemberQ[DifFormSymbols, u], _tr}]; ];

NoDif[z__] := (nodHeads = Union[nodHeads, Flatten[{z}]]; )

BasicMatQ[Bar[x_]] := BasicMatQ[x]; BasicMatQ[d[x_]] := BasicMatQ[x]; 
    BasicMatQ[x_List] = True; BasicMatQ[x_] := False;

MatQ[x_Times | x_Wedge | x_Plus] := Or@@MatQ/@List@@x; 
    MatQ[x_SeriesData] := Or@@MatQ/@x[[3]]; MatQ[x_] := BasicMatQ[x];

BasicScalFormQ[HoldPattern[tr[x_]]] := FormDegree[x] > 0; 
    BasicScalFormQ[Bar[x_]] := BasicScalFormQ[x]; 
    BasicScalFormQ[d[x_]] := ! BasicMatQ[x]; BasicScalFormQ[x_] := False;

ScalFormQ[x_Times] := Or@@ScalFormQ/@List@@x; 
    ScalFormQ[x_Wedge | x_Plus] := And@@ScalFormQ/@List@@x; 
    ScalFormQ[x_] := BasicScalFormQ[x];

Unprotect[Transpose]; Transpose[x_Plus] := Transpose/@x; 
    Transpose[x_SeriesData] := x /. x[[3]] -> Transpose/@x[[3]]; 
    Transpose[x__ y_] := x Transpose[y] /; ! MatQ[x]; 
    Transpose[x__⋀y__] := 
      (x⋀Transpose[Wedge[y]]) /; ScalFormQ[x]; 
    Transpose[x_Wedge] := 
      (-1)^allFDprods[FormDegree/@(List@@x)] 
        Wedge@@Map[Transpose, Reverse[List@@x]]; 
    Transpose[d[x_]] := d[Transpose[x]]; 
    HoldPattern[Transpose[Bar[x_]]] := Bar[Transpose[x]]; 
    Transpose[x_] := x /; ! MatQ[x]; Protect[Transpose];

SymQ[Bar[x_]] := Union[Flatten[{reWrite[Transpose[x] - x]}]] === {0}; 
    AntisymQ[Bar[x_]] := Union[Flatten[{reWrite[Transpose[x] + x]}]] === {0}; 
    SymQ[x_] := Union[Flatten[{reWrite[Transpose[x] - x]}]] === {0}; 
    AntisymQ[x_] := Union[Flatten[{reWrite[Transpose[x] + x]}]] === {0};

SetAttributes[d, {Listable}]; 
    d[x_Times | x_Wedge] := 
      d[First[x]]⋀Rest[x] + 
        (-1)^FormDegree[First[x]]*First[x]⋀d[Rest[x]]; 
    d[x_?NumericQ | x_d] = 0; d[matDimension] = 0; 
    d[Power[y_, n_]] := n y^(n - 1) d[y] + y^n Log[y] d[n]; 
    d[x_Plus] := d/@x; 
    HoldPattern[d[tr[x_]]] := 
      With[{evalHx = d[x]}, tr[evalHx] /; Head[evalHx] =!= d]; 
    HoldPattern[d[Bar[x_]]] := 
      With[{evalHx = d[x]}, Bar[evalHx] /; Head[evalHx] =!= d]; 
    d[x_Rule | x_Equal] := reWrite[d/@x]; 
    d[x_SeriesData] := 
      (x /. x[[3]] -> d[x[[3]]]) + 
        Wedge[d[First[x]], D[x, First[x]]]; 
    d[h_[y__] /; ! MemberQ[nodHeads, h]] := 
      Sum[(Derivative[
                    Sequence@@
                      RotateRight[Append[Table[0, {Length[{y}] - 1}], 1], i]]
                    [h][y]) d[{y}[[i]]], {i, Length[{y}]}] /; 
        FormDegree[h[y]] === 0 && 
          ! MemberQ[{Integer, Blank, Pattern, Condition}, Head[First[{y}]]]
              ;

newSer$[x_SeriesData, k_] := 
      SeriesData[First[x], x[[2]], 
        Flatten[Transpose[
            Prepend[Table[Table[0, {Length[x[[3]]]}], {k - 1}], 
              x[[3]]]]], k x[[4]], k x[[5]], k Last[x]]

Wedge[x_] := x /; Length[{x}] < 2 && Head[{x}[[1]]] =!= Pattern

Default[Wedge] := 1; SetAttributes[Wedge, {Flat, OneIdentity}]; 
    Wedge[0, y__] = 0; Wedge[x__, 0] = 0; 
    Wedge[x_SeriesData, y_SeriesData] := 
      Block[{x$, y$, r1, r2, res, x3, y3}, 
          If[Last[x] === Last[y], x$ = x; y$ = y, 
            x$ = newSer$[x, LCM[Last[x], Last[y]]/Last[x]]; 
            y$ = newSer$[y, LCM[Last[x], Last[y]]/Last[y]]]; 
          r1 = x$[[-3]] + y$[[-3]]; 
          r2 = Min[x$[[-2]] + y$[[-3]], 
              x$[[-3]] + y$[[-2]]]; 
          If[Length[x$[[3]]] < x$[[-2]] - x$[[-3]], 
            x3 = Join[x$[[3]], 
                Table[0, {
                    x$[[-2]] - x$[[-3]] - 
                      Length[x$[[3]]]}]], x3 = x$[[3]]]; 
          If[Length[y$[[3]]] < y$[[-2]] - y$[[-3]], 
            y3 = Join[y$[[3]], 
                Table[0, {
                    y$[[-2]] - y$[[-3]] - 
                      Length[y$[[3]]]}]], y3 = y$[[3]]]; 
          Which[r2 === r1, res = {}, 
            r2 - r1 === x$[[-2]] - x$[[-3]], 
            res = Sum[
                Map[Wedge[x3[[i]], #]&, 
                  Join[Table[0, {i - 1}], Drop[y3, -i + 1]]], {i, 
                  Length[x3]}], True, 
            res = Sum[
                Map[Wedge[#, y3[[i]]]&, 
                  Join[Table[0, {i - 1}], Drop[x3, -i + 1]]], {i, 
                  Length[y3]}]]; 
          SeriesData[First[x$], x$[[2]], res, r1, r2, Last[x$]]] /; 
        First[x] === First[y] && x[[2]] === y[[2]]; 
    Wedge[y_, x_SeriesData] := 
      x /. x[[3]] -> Map[Wedge[y, #]&, x[[3]]]; 
    Wedge[x_SeriesData, y_] := 
      x /. x[[3]] -> Map[Wedge[#, y]&, x[[3]]]; 
    Wedge[x__, y_Plus] := Plus@@Map[Wedge[x, #]&, List@@y]; 
    Wedge[x_Plus, y__] := Plus@@Map[Wedge[#, y]&, List@@x]; 
    Wedge[u__, Times[x_, y_]] := 
      Times[x, Wedge[u, y]] /; 
        NumericQ[x] || (FormDegree[x] === 0 && ! MatQ[x]); 
    Wedge[Times[x_, y_], z__] := 
      Times[x, Wedge[y, z]] /; 
        NumericQ[x] || (FormDegree[x] === 0 && ! MatQ[x]); 
    x_^n_.⋀y_  := x^n*y /; FormDegree[x] === 0 && ! MatQ[x]; 
    y_⋀x_^n_. := x^n*y /; FormDegree[x] === 0 && ! MatQ[x]; 
    Wedge[x_, y___, x_] := 0 /; OddQ[FormDegree[x]] && ScalFormQ[x]; 
    Wedge[x__, y__] := 
      (-1)^(FormDegree[x]*FormDegree[y])*y⋀x /; 
        MatQ[x] && ScalFormQ[y]; 
    Wedge[x__] := 
      Block[{doubL = Transpose[{FormDegree/@{x}, {x}}]}, 
          Signature[Select[doubL, OddQ[First[#]]&]] 
            Wedge@@Map[Last[#1]&, Sort[doubL]]] /; 
        Union[BasicScalFormQ/@{x}] === {True} && 
          Map[Last[#1]&, Sort[Transpose[{FormDegree/@{x}, {x}}]]] =!= {x}; 
    Wedge[x_List, y_List] := 
      If[(FormDegree[x] === 0 && 
              ! MatQ[First[Select[Union[Flatten[x]], ! zeroQ[#]&]]])
             || (
            FormDegree[y] === 0 && 
              ! MatQ[First[Select[Union[Flatten[y]], ! zeroQ[#]&]]])
            , Dot[x, y], Inner[Wedge, x, y]]; 
    Wedge[x_, y_List] := 
      If[FormDegree[x] === 0 || 
            (FormDegree[y] === 0 && 
                ! MatQ[First[Select[Union[Flatten[y]], ! zeroQ[#]&]]])
              , x *y, Map[Wedge[x, #]&, y]] /; ! BasicMatQ[x];

simpRules  =  {Cos[z_]^2*(x_.) + (x_.)*Sin[z_]^2  ->  x}; 
    varList = {};

coll[x_] := Collect[x, {_Wedge, _tr}, Factor];

SetAttributes[reWrite, {Listable}]; reWrite[0] = 0; 
    reWrite[x_Equal] := Equal[reWrite[First[x] - Last[x]], 0]; 
    reWrite[x_Rule] := Rule[First[x], reWrite[Last[x]]]; 
    reWrite[x_SeriesData] := (x /. x[[3]] -> reWrite[x[[3]]]); 
    reWrite[x_] := 
      (Collect[coll[x] /. simpRules, FormVars, bestFacRul] /. simpRules)
           /; FormDegree[x] > 0; 
    reWrite[x_] := 
      (Collect[x /. simpRules, ZeroVars, bestFacRul] /. simpRules) /; 
        MatQ[x]; reWrite[x_] := bestFacRul[x /. simpRules] /. simpRules;

FreeALLQ[x_, y_List] := And@@Map[FreeQ[x, #]&, y];

bestFacRul[x_] := 
      If[varList === {} || FreeALLQ[x, varList], minFacRul[x], varFacRul[x]]; 
    varFacRul[x_] := 
      Collect[Expand[x] /. simpRules, varList, Factor] /. simpRules; 
    minFacRul[x_] := Factor[Expand[x] /. simpRules] /. simpRules;

Unprotect[SeriesData]; 
    If[$VersionNumber < 5, Times[x_SeriesData, 0] ^= 0]; 
    SeriesData[x1_, x2_, x3_, x4_, x5_, x6_] :=  
      Plus@@If[x2 === Infinity, 
            Map[First[#]/x1^((x4 + Last[#] - 1)/x6)&, 
                Transpose[{x3, Range[Length[x3]]}]] + 
              SeriesData[x1, x2, {}, x4, x5, x6],    
            Map[First[#]*(x1 - x2)^((x4 + Last[#] - 1)/x6)&, 
                Transpose[{x3, Range[Length[x3]]}]] + 
              SeriesData[x1, x2, {}, x4, x5, x6]] /; ! FreeQ[x3, x1]; 
    Protect[SeriesData];

CHcoef[x_, 0] = 1; CHcoef[x_, 1] := tr[x]; 
    CHcoef[x_, n_] := CHcoef[x, n] = reWrite[tr[CHeq[x, n]]/n];

CHeq[x_, n_] := 
      reWrite[CHcoef[x, n - 1]⋀ x + 
          Sum[(-1)^(i - 1) 
              CHcoef[x, n - i]⋀Wedge@@Table[x, {i}], {i, 2, n}]];

DeclareMatrixForms[{0, $, $t}]

CHrul[n_, x_:  $] := 
      Block[{cn = CHeq[x, n], cn0, rul, tmp, r1, r2}, 
        If[FormDegree[x] > 0, Print[x, " is not a 0-form matrix"]; 
          Return[]];  matDimension = n; 
        rul = First[Solve[cn == cn0, Wedge@@Table[x, {n}]]] /. 
            cn0 -> tr[cn]/n; rul = reWrite[rul]; 
        If[x === $, 
          tmp = MapAt[HoldPattern, rul /. Rule -> RuleDelayed, {1, 1}]; 
          r1 = tmp[[1, 1]]; r2 = r1 /. $ -> Pattern[$, Blank[]]; 
          tmp = {Rule[r2, 
                  tmp[[1, 2]] /; 
                    MatQ[$] && FormDegree[$] === 0 && matDimension === n]} /. 
              Rule -> RuleDelayed, tmp = rul]];

On[General::"spell", General::"spell1", UpSet::"write"];