1
$\begingroup$

I want to build a Cartesian product of two posets (say chain[2] and chain[2]).
I wrote

Build[CP[Chain[2], Chain[2]], square]

the functions Build[] and CProduct[] (CP[] for short) are from posets300.m package.

I got the messge

Thread::tdlen: Objects of unequal length in {{{{1,1},{0,1}},{{1,1},{0,1}}},{{{0,0},{0,0}},{{1,1},{0,1}}}}+{{-1,0,0,0},{0,-1,0,0},{0,0,-1,0},{0,0,0,-1}} cannot be combined.`

Building poset square  ...

Done

Then I wrote

Diagram[square]

and got

enter image description here

I digged in the package to look at the function description. Here it is description of the function CProduct[] from the package:

CProduct[poset1_,poset2_] := 
  Block[{mat1,mat2,mat3,card1,card2},
  If[Head[poset1]===Symbol,
     {mat1,card1}={ZetaP[poset1],Card[poset1]},(*else*)
     If[MatrixQ[poset1],
       {mat1,card1}={poset1,Length[poset1]},(*else*)
       {mat1,card1}=
           {ToMatrix[poset1[[1]],poset1[[2]]],poset1[[2]]}
     ]
   ];
  If[Head[poset2]===Symbol,
     {mat2,card2}={ZetaP[poset2],Card[poset2]},(*else*)
     If[MatrixQ[poset1],
       {mat2,card2}={poset2,Length[poset2]},(*else*)
       {mat2,card2}=
           {ToMatrix[poset2[[1]],poset2[[2]]],poset2[[2]]}
     ]
   ];   
  card=card1 card2;
  Do[mat1[[i,i]]=1,{i,card1}];
  Do[mat2[[i,i]]=1,{i,card2}];
  mat3=TensorProduct[mat1,mat2];
  {ToRelation[mat3-IdentityMatrix[card]],card}
  ];

I tried to change TensorProduct[] by KroneckerProduct[] and ran the function by parts as follows:

In[63]:= mat1 = 0
mat2 = 0
card1 = 0
card2 = 0


Out[63]= 0

Out[64]= 0

Out[65]= 0

Out[66]= 0

In[67]:= If[
  Head[poset1] === 
   Symbol, {mat1, card1} = {ZetaP[poset1], Card[poset1]},(*else*)
  If[MatrixQ[
    poset1], {mat1, card1} = {poset1, Length[poset1]},(*else*){mat1, 
     card1} = {ToMatrix[poset1[[1]], poset1[[2]]], poset1[[2]]}]];
If[Head[poset2] === 
   Symbol, {mat2, card2} = {ZetaP[poset2], Card[poset2]},(*else*)
  If[MatrixQ[
    poset1], {mat2, card2} = {poset2, Length[poset2]},(*else*){mat2, 
     card2} = {ToMatrix[poset2[[1]], poset2[[2]]], poset2[[2]]}]];

In[69]:= card1

Out[69]= 2

In[70]:= card2

Out[70]= 2

In[71]:= mat1

Out[71]= {{0, 1}, {0, 0}}

In[72]:= mat2

Out[72]= {{0, 1}, {0, 0}}

In[73]:= card = card1 card2


Out[73]= 4

In[74]:= Do[mat1[[i, i]] = 1, {i, card1}]


In[75]:= Do[mat2[[i, i]] = 1, {i, card2}]

In[76]:= mat3 = KroneckerProduct[mat1, mat2]

Out[76]= {{1, 1, 1, 1}, {0, 1, 0, 1}, {0, 0, 1, 1}, {0, 0, 0, 1}}

In[77]:= pos = ToRelation[mat3 - IdentityMatrix[card]]

Out[77]= {{1, 2}, {1, 3}, {1, 4}, {2, 4}, {3, 4}}

In[78]:= Build[{pos, 4}, square1]

During evaluation of In[78]:= Building poset square1  ...

During evaluation of In[78]:= Done

Then I got the correct poset I wantet to build: enter image description here

Then I changed the description of CProduct[] in the package as follows:

CProduct[poset1_,poset2_] := 
  Block[{mat1,mat2,mat3,card1,card2},
  If[Head[poset1]===Symbol,
     {mat1,card1}={ZetaP[poset1],Card[poset1]},(*else*)
     If[MatrixQ[poset1],
       {mat1,card1}={poset1,Length[poset1]},(*else*)
       {mat1,card1}=
           {ToMatrix[poset1[[1]],poset1[[2]]],poset1[[2]]}
     ]
   ];
  If[Head[poset2]===Symbol,
     {mat2,card2}={ZetaP[poset2],Card[poset2]},(*else*)
     If[MatrixQ[poset1],
       {mat2,card2}={poset2,Length[poset2]},(*else*)
       {mat2,card2}=
           {ToMatrix[poset2[[1]],poset2[[2]]],poset2[[2]]}
     ]
   ];   
  card=card1 card2;
  Do[mat1[[i,i]]=1,{i,card1}];
  Do[mat2[[i,i]]=1,{i,card2}];
  mat3=KroneckerProduct[mat1,mat2];
  {Position[mat3-IdentityMatrix[card],1],card}
  ];

I ran the Build[CProduct[Chain[2], Chain[2]], square] again but the error surprisingly remained :(

It seems that TensorProduct[] defined by author of the package posets300.m did not work well.

Here it is the description:

TensorProduct[M_,N_] :=  Map[Flatten,
    Flatten[Transpose[
      Outer[Times,M,N],{1,3,2,4}],1]];

I changed the TensorProduct[] by KroneckerProduct[] in the function CProduct[] as follow:

Unprotect[CProduct]; 
 CProduct[poset1_, poset2_] := 
  Block[{mat1, mat2, mat3, card1, card2}, 
   If[Head[poset1] === 
     Symbol, {mat1, card1} = {ZetaP[poset1], Card[poset1]},(*else*)
    If[MatrixQ[
      poset1], {mat1, card1} = {poset1, Length[poset1]},(*else*){mat1,
        card1} = {ToMatrix[poset1[[1]], poset1[[2]]], poset1[[2]]}]];
   If[Head[poset2] === 
     Symbol, {mat2, card2} = {ZetaP[poset2], Card[poset2]},(*else*)
    If[MatrixQ[
      poset1], {mat2, card2} = {poset2, Length[poset2]},(*else*){mat2,
        card2} = {ToMatrix[poset2[[1]], poset2[[2]]], poset2[[2]]}]];
   card = card1 card2;
   Do[mat1[[i, i]] = 1, {i, card1}];
   Do[mat2[[i, i]] = 1, {i, card2}];
   mat3 = KroneckerProduct[mat1, mat2];
   {Position[mat3 - IdentityMatrix[card], 1], card}]; 
 Protect[CProduct];) 

It worked well while I closed the notebook.

Now it does not work again.

That is I need to run

(Unprotect[CProduct]; 
 CProduct[poset1_, poset2_] := 
  Block[{mat1, mat2, mat3, card1, card2}, 
   If[Head[poset1] === 
     Symbol, {mat1, card1} = {ZetaP[poset1], Card[poset1]},(*else*)
    If[MatrixQ[
      poset1], {mat1, card1} = {poset1, Length[poset1]},(*else*){mat1,
        card1} = {ToMatrix[poset1[[1]], poset1[[2]]], poset1[[2]]}]];
   If[Head[poset2] === 
     Symbol, {mat2, card2} = {ZetaP[poset2], Card[poset2]},(*else*)
    If[MatrixQ[
      poset1], {mat2, card2} = {poset2, Length[poset2]},(*else*){mat2,
        card2} = {ToMatrix[poset2[[1]], poset2[[2]]], poset2[[2]]}]];
   card = card1 card2;
   Do[mat1[[i, i]] = 1, {i, card1}];
   Do[mat2[[i, i]] = 1, {i, card2}];
   mat3 = KroneckerProduct[mat1, mat2];
   {Position[mat3 - IdentityMatrix[card], 1], card}]; 
 Protect[CProduct];)

every time I open the notebook.

Can I change the package accordingly to not run the Unprotect[]-Protect[] over and over?

$\endgroup$
  • 1
    $\begingroup$ Since this is not a high-profile package (not something I have seen mentioned here), you might have better luck if you contact the package's author (and maybe point them to this question). $\endgroup$ – Szabolcs Feb 21 at 10:38
  • 1
    $\begingroup$ Also, please link to the package (don't just mention the name) and add the name of the package in the question title. $\endgroup$ – Szabolcs Feb 21 at 11:41
  • $\begingroup$ @Szabolcs Done, thank you. $\endgroup$ – Evgeny Kuznetsov Feb 21 at 16:04

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Browse other questions tagged or ask your own question.