Code for monad algebras

This Mathematica notebook is licensed under a MouseOver 
It creates the demonstrations used in my post Monads for High School III:Algebras

I hope anyone interested will feel free to improve this work and to use it in their own publications and coursework.

Monad Experiments notebook

Basic definitions

Show lists

basesty[list_,color_]:=Framed[Style[list,Medium, 12, FontFamily->"Arial",Background->White],FrameStyle->Directive[color]]

basesty[list_]:=Framed[Style[list,Medium, 12, FontFamily->"Arial",Background->White]]

basesty[{3,5,7},Green]

baresty[list_]:=Style[list,Medium, 14, FontFamily->"Arial",Background->White]

baresty[23]

basesty[Grid[{{3,5,7}}]]

cartouche[list_,color_]:=basesty[Grid[{list}],color]

cartouche[list_]:=basesty[Grid[{list}],Black]

cartouche[{3,5,7}]

cartouche[{3,5,7},Blue]

listcar[list_,place_]:=Text[cartouche[list],place]

Show list of lists

cartouche[{cartouche[{3,5,7}],cartouche[{2,44,14,15,6}]},Blue]

cartouche[#]&/@{{3,5,7},{4,5,6,7}}

cartouche[{({{3, 5, 7}}),({{4, 5, 6, 7}})},Blue]

cartouche[#,Blue]&@@{{({{3, 5, 7}}),({{4, 5, 6, 7}})}}

list2[list_]:=cartouche[#,Blue]&@@{cartouche[#]&/@list}

list2[{{3,5,7},{4,5,6,7}}]

list2[{{1},{2},{3}}]

list2[{{3,5},{4,4,5,66},{3},{},{88,4}}]

list3[list_]:=cartouche[#,Green]& @@{list2[#]&/@list}

list3[{{{1,2,3},{4},{33,2,4}},{{3,4,5},{5,6}},{{7,6},{4,5,44}}}]

Make tree diagrams

op[x_,loc_]:=Text[Style[x,13,Background->White,FontFamily->"Arial"],loc]

op[x_,loc_,weight_]:=Text[Style[x,13,weight,Background->White,FontFamily->"Arial"],loc]

op[x_,loc_,weight_,color_]:=Text[Style[x,13,weight,color,Background->White,FontFamily->"Arial"],loc]

op["x",{0,1}]

op["Plus\n" a+b,{0,0}]

edge[loc1_,loc2_,sf_]:=Arrow[{loc1,loc2},Scaled[sf]]

spd=.0006

Monad of lists

Definitions

alabel[name_,pos_]:=Text[Style[name,FontSize->12,FontFamily->"Arial"],Scaled[pos],Background->White]

myarr[pos1_,pos2_,setback_]:=Arrow[{Scaled[pos1],Scaled[pos2]},Scaled[setback]]

Join @@{{1,2},{3,4,5},{6},{7,8}}(*end result*)

Join@@{{{1,2}},{{3,4,5},{6,7}},{{8,9},{10}}}(*outside first*)

Apply[Join,{{{1,2}},{{3,4,5},{6,7}},{{8,9},{10}}},1](*inside first*)

Join@@(Join@@{{{1,2}},{{3,4,5},{6,7}},{{8,9},{10}}})

starttest:={{{1,2}},{{3,4,5},{6,7}},{{8,9},{10}}}

Apply[Join,starttest,1]

Join@@starttest

labelsty[txt_]:=Style[txt,12, FontFamily->"Arial",Background->White]

labelsty["join"]

assocdiag[start_,size_]:=
Module[
{
insfirst=Apply[Join,start,1],
outsfirst=Join@@start,
end1=Join@@(Join@@start),
end2=Join@@(Apply[Join,start,1]),
lab1=labelsty["join inside first"],
lab2=labelsty["join outside first"],
lab3=labelsty["join"],
lab4=labelsty["join"]
},
Graphics[
{Arrowheads[.03],,myarr[{0,0},{.5,1.03},.0016],myarr[{0,0},{.5,-1.03},.0016],myarr[{.5,1},{1.05,.13},.0014],myarr[{.5,-1},{1.05,-.12},.0014],alabel[lab1,.5({0,0}+{.5,1})],alabel[lab2,.5({0,0}+{.5,-1})],
alabel[lab3 ,.5({.5,1}+{1.05,.15})],alabel[lab4,.5({.5,-1}+{1.05,-.15})],
Inset[list3[start],Scaled[{0,0}]],Inset[list2[insfirst],Scaled[{.5,1}]],Inset[list2[outsfirst],Scaled[{.5,-1}]],Inset[cartouche[end1],Scaled[{1,.2}]],Inset[cartouche[end2],Scaled[{1,-.2}]]
},
AspectRatio->.3,ImageSize->size
]
]

assocdiag[start_]:=assocdiag[start,500]

assocdiag[{{{5,2}},{{3,4,7},{6,7}},{{7,4},{10}}},500]

This is MainMonadDiag.cdf for the monad of lists

<script type=”text/javascript” src=”http://www.wolfram.com/cdf-player/plugin/v2.1/cdfplugin.js”></script>
<script type=”text/javascript”>
var cdf = new cdfplugin();
cdf.setDefaultContent(‘<a href=”http://www.wolfram.com/cdf-player/”><img  src=”MainMonadDiag.png”></a>’);
cdf.embed(‘https://abstractmath.org/Mathematica/MainMonadDiag.cdf’, 661, 322);
</script>

Manipulate[
Module[{lst=Switch[ s,
1,{{{5,2}},{{3,4,7},{6,7}},{{5}},{{7,4},{10},{6}}},
2,{{{7,5},{}},{{},{3,4},{5}},{{}}},
3,{{{a,b,c}},{{}},{{a,b,c} ,{}}},
4,{{{a,a,a},{}},{{a}},{{a},{},{d,c}}},
5,{{{1},{2}}},
6,{{{1}}},
7,{{{}},{{}},{{},{}}}
],
size=Switch[s,1,600,2,450,3,475,4,500,5,300,6,250,7,400]
},
assocdiag[lst,size]],{{s,1,"Examples"},{1,2,3,4,5,6,7},ControlType->RadioButtonBar},Paneled->False ,SaveDefinitions->True
]

Monad unit law

startex2:={7,4,10}

cartouche[startex2]

list2[{startex2}]

Map[List,{1,2,3}]

list2[Map[List,startex2]]

cartouche[Join@@({startex2})]

cartouche[Join@@Map[List,startex2]]

unitdiag[start_,size_]:=
Module[
{
insfirst=list2[{start}],
outsfirst=list2[Map[List,start]],
end1=cartouche[Join@@({start})],
end2=cartouche[Join@@Map[List,start]],
lab2=labelsty["singleton each"],
lab1=labelsty["singleton list"],
lab3=labelsty["join"],
lab4=labelsty["join"]
},
Graphics[
{Arrowheads[.03],myarr[{0,0},{.5,1},.0012],myarr[{0,0},{.5,-1},.0013],myarr[{.5,1},{1,.1},.001],myarr[{.5,-1},{1,-.1},.0010],
alabel[lab1,.5({0,0}+{.5,1})],
alabel[lab2,.5({0,0}+{.5,-1})],
alabel[lab3 ,.5({.5,1}+{1.,.15})],alabel[lab4,.5({.5,-1}+{1.,-.15})],
Inset[cartouche[start],Scaled[{0,0}]],Inset[insfirst,Scaled[{.5,1}]],Inset[outsfirst,Scaled[{.5,-1}]],Inset[end1,Scaled[{1,.2}]],Inset[end2,Scaled[{1,-.2}]]
},
AspectRatio->.2,ImageSize->size
]
]

unitdiag[startex2,500]

MonadUnitDiag.cdf

<script type=”text/javascript” src=”http://www.wolfram.com/cdf-player/plugin/v2.1/cdfplugin.js”></script><script type=”text/javascript”>
var cdf = new cdfplugin();
cdf.setDefaultContent(‘<a href=”http://www.wolfram.com/cdf-player/”><img src=”MonadUnitDiag.png”/></a>’);
cdf.embed(‘https://abstractmath.org/Mathematica/MonadUnitDiag.cdf’, 555, 279);
</script>

Manipulate[
Module[{lst=Switch[ s,
1,{7,4,10,7},
2,{3},
3,{}
],
size=Switch[s,1,500,2,350,3,350]
},
unitdiag[lst,size]],{{s,1,"Examples"},{1,2,3},ControlType->RadioButtonBar},Paneled->False ,SaveDefinitions->True
]

Algebras

Plus@@{3,3,4,5}

algop[binop_,list_]:=binop@@list

algop[Plus,{3,3,4,5}]

algop[Times,{2,4,4}]

startex:={{1,3,3},{2},{},{5,5,4}}

list2[startex]

Apply[Plus,startex,1]

Plus@@(Apply[Plus,startex,1])

cartouche[Apply[Plus,startex,1]]

Join@@startex

Plus@@(Join@@startex)

algdiag[start_,size_]:=
Module[
{
insfirst=Apply[Plus,start,1],
joinedlist=Join@@start,
end1=Plus@@(Apply[Plus,start,1]),
end2=Plus@@(Join@@start),
lab1=labelsty["algop insides"],
lab2=labelsty["join"],
lab3=labelsty["algop"],
lab4=labelsty["algop"]
},
Graphics[
{Arrowheads[.03],,myarr[{0,0},{.5,1.03},.0016],myarr[{0,0},{.5,-1.03},.0016],myarr[{.5,1},{1.05,.13},.0014],myarr[{.5,-1},{1.05,-.12},.0014],alabel[lab1,.5({0,0}+{.5,1})],alabel[lab2,.5({0,0}+{.5,-1})],
alabel[lab3 ,.5({.5,1}+{1.05,.15})],alabel[lab4,.5({.5,-1}+{1.05,-.15})],
Inset[list2[start],Scaled[{0,0}]],Inset[cartouche[insfirst],Scaled[{.5,1}]],Inset[cartouche[joinedlist],Scaled[{.5,-1}]],Inset[baresty[end1],Scaled[{1,.2}]],Inset[baresty[end2],Scaled[{1,-.2}]]
},
AspectRatio->.3,ImageSize->size
]
]

algdiag[startex,400]

Allow multiple ops

startex:={{1,3,3},{2},{},{5,5,4}}

Join@@startex

Apply[Plus,startex,1]

gop=Times;Apply[gop,startex,1]

Apply[Times,startex,1]

Length/@startex

Length[Join@@startex]

Plus@@(Apply[Plus,startex,1])

Plus@@(Join@@startex)

Length[Length/@startex]

algop:=Plus

If[algop==Length,"yes","no"]

If [algop==Length,Length[Length/@startex],algop@@Apply[algop,startex,1]]

algdiag[start_,algop_,size_]:=
Module[
{
insfirst=Apply[algop,start,1],
joinedlist=Join@@start,
end1=algop@@Apply[algop,start,1],
end2=algop@@(Join@@start),
lab1=labelsty[ ToString[algop]<>" insides"],
lab2=labelsty["join"],
lab3=labelsty[ToString[algop]],
lab4=labelsty[ToString[algop]]
},
Graphics[
{Arrowheads[.03],myarr[{0,0},{.5,1.03},.0016],myarr[{0,0},{.5,-1.03},.0016],myarr[{.5,1},{1.05,.13},.0014],myarr[{.5,-1},{1.05,-.12},.0014],alabel[lab1,.5({0,0}+{.5,1})],alabel[lab2,.5({0,0}+{.5,-1})],
alabel[lab3 ,.5({.5,1}+{1.05,.15})],alabel[lab4,.5({.5,-1}+{1.05,-.15})],
Inset[list2[start],Scaled[{0,0}]],Inset[cartouche[insfirst],Scaled[{.5,1}]],Inset[cartouche[joinedlist],Scaled[{.5,-1}]],Inset[baresty[end1],Scaled[{1,.2}]],Inset[baresty[end2],Scaled[{1,-.2}]]
},
AspectRatio->.3,ImageSize->size
]
]

algdiag[startex,Times,400]

algdiag[startex,Plus,400]

property diagram for algops without op parameter

Manipulate[
Module[{lst=Switch[ s,
1,{{5,2},{26,4,-7},{0},{5},{0,7,4},{-10},{6}},
2,{{7,5},{},{},{3,4},{5,0},{}},
3,{{1,2,3},{1},{2},{3}},
4,{{1,1,1},{},{0},{1},{},{2,-2}},
5,{{42}},
6,{{1},{2}},
7,{{1,2}},
8,{{},{}}
],
size=Switch[s,1,400,2,350,3,325,4,400,5,300,6,250,7,250,8,225]
},
algdiag[lst,size]],{{s,1,"Examples"},{1,2,3,4,5,6,7,8},ControlType->RadioButtonBar},Paneled->False ,SaveDefinitions->True
]

Main property diagram for Algebra AlgopDiag.cdf

<script type="text/javascript" src="http://www.wolfram.com/cdf-player/plugin/v2.1/cdfplugin.js"></script>
<script type="text/javascript">
var cdf = new cdfplugin();
cdf.setDefaultContent('<a href="http://www.wolfram.com/cdf-player/"><img  src="AlgopDiag.png"></a>');
cdf.embed('https://abstractmath.org/Mathematica/AlgopDiag.cdf', 449, 250);
</script>

Manipulate[
Module[{lst=Switch[ s,
1,{{5,7},{24,4,-7},{1},{},{1,7,4},{-10},{6}},
2,{{7,5},{},{},{3,4},{5,1},{}},
3,{{1,2,3},{1},{2},{3}},
4,{{1,1,1},{},{0},{1},{},{2,-2}},
5,{{42}},
6,{{2},{3}},
7,{{2,3}},
8,{{},{}}
],
size=Switch[s,1,400,2,350,3,325,4,400,5,300,6,250,7,250,8,225],
op=Switch[o,1,Plus,2,Times,3,Length]
},
algdiag[lst,op,size]],{{s,1,"Examples"},{1,2,3,4,5,6,7,8},ControlType->RadioButtonBar},{{o,1,"BinOp"},{1->"Plus",2->"Times"},ControlType->RadioButtonBar},Paneled->False ,SaveDefinitions->True
]

Unitary property for Monad Algebras

Graphics[
{Arrowheads[.03],myarr[{0,0},{.5,0},.0002],myarr[{.5,0},{1,0},.00018],alabel["singleton",{.25,.4}],alabel["algop",{.75,.4}],
Inset[baresty["a"],Scaled[{0,0}]],Inset[cartouche[{"a"}],Scaled[{.5,0}]],Inset[baresty["a"],Scaled[{1,0}]]},
AspectRatio->.1,ImageSize->300
]

Recovering associativity

Tree diagrams for associativity

Manipulate[
Grid[{{
Graphics[{
Arrowheads[0],
op[If [s>1,"(a+b)+c","algop"],{-.5,2}],
op[If[s>0,"a+b","algop"],{-1,1}],
op["a",{-1.5,0}],
op["b",{-.5,0}],
op["c",{.5,0}],
edge[{-.5,2},{-1,1},spd],
edge[{-.5,2},{.5,0},spd],
edge[{-1,1},{-1.5,0},spd],
edge[{-1,1},{-.5,0},spd]
},
Background->White,ImageSize->100, AspectRatio->1],"     ",
Graphics[{
Arrowheads[0],
op[If [s>1,"a+(b+c)","algop"],{-.5,2}],
op[If[s>0,"b+c","algop"],{0,1}],
op["a",{-1.5,0}],
op["b",{-.5,0}],
op["c",{.5,0}],
edge[{-.5,2},{-1.5,0},spd],
edge[{-.5,2},{0,1},spd],
edge[{0,1},{-.5,0},spd],
edge[{0,1},{.5,0},spd]
},
Background->White,ImageSize->100, AspectRatio->1]}}],
{{s,0,"Steps"},{0->"Reset",1,2}},
Paneled->False,
ControlPlacement->Left,
SaveDefinitions->True]

Diagrams to show equal

alopleft:=Graphics[{
Arrowheads[0],
op["alop",{-.5,2}],
op["alop",{-1,1}],
op["a",{-1.5,0}],
op["b",{-.5,0}],
op["c",{.5,0}],
edge[{-.5,2},{-1,1},spd],
edge[{-.5,2},{.5,0},spd],
edge[{-1,1},{-1.5,0},spd],
edge[{-1,1},{-.5,0},spd]
},
Background->White,ImageSize->60, AspectRatio->1]

alopleft

alopright:=Graphics[{
Arrowheads[0],
op["alop",{-.5,2}],
op["alop",{0,1}],
op["a",{-1.5,0}],
op["b",{-.5,0}],
op["c",{.5,0}],
edge[{-.5,2},{-1.5,0},spd],
edge[{-.5,2},{0,1},spd],
edge[{0,1},{-.5,0},spd],
edge[{0,1},{.5,0},spd]
},
Background->White,ImageSize->60, AspectRatio->1]

alopright

aloptriple:=Graphics[{
Arrowheads[0],
op["alop",{0,1}],
op["a",{-1,0}],
op["b",{0,0}],
op["c",{1,0}],
edge[{0,1},{-1,0},spd],
edge[{0,1},{0,0},spd],
edge[{0,1},{1,0},spd]
},
Background->White,ImageSize->50, AspectRatio->1]

aloptriple

alopsingle[char_]:=Graphics[{
Arrowheads[0],
op[char,{1,0}]},
Background->White,ImageSize->20, AspectRatio->1]

alopsingle["c"]

alopsingle[a]

alopdouble[char1_,char2_]:= Graphics[{
Arrowheads[0],
op["alop",{0,1}],
op[char1,{-.5,0}],
op[char2,{.5,0}],
edge[{0,1},{-.5,0},spd],
edge[{0,1},{.5,0},spd]
},
Background->White,ImageSize->30, AspectRatio->1]

alopdouble["a","b"]

list2[{{a,b},{c}}]

cartouche[{alopdouble["a","b"],alopsingle["c"]}]

These diagrams show how associativity is forced using trees

algdiagleft:=Graphics[
{Arrowheads[.03],myarr[{0,0},{.5,1.03},.0016],myarr[{0,0},{.5,-1.03},.0016],myarr[{.5,1},{1.05,.2},.0014],myarr[{.5,-1},{1.05,-.2},.0014],alabel[labelsty[ ToString[alop]<>" insides"],.5({0,0}+{.5,1})],alabel[labelsty["join"],.5({0,0}+{.5,-1})],
alabel[labelsty[ToString[alop]],.5({.5,1}+{1.05,.2})],alabel[labelsty[ToString[alop]],.5({.5,-1}+{1.05,-.2})],
Inset[list2[{{a,b},{c}}],Scaled[{0,0}]],Inset[cartouche[{alopdouble["a","b"],alopsingle["c"]}],Scaled[{.5,1}]],Inset[cartouche[Join@@{{a,b},{c}}],Scaled[{.5,-1}]],Inset[baresty[alopleft],Scaled[{1,.4}]],Inset[baresty[aloptriple],Scaled[{1,-.4}]]
},
AspectRatio->.3,ImageSize->400
]

algdiagleft

algdiagright:=Graphics[
{Arrowheads[.03],myarr[{0,0},{.5,1.03},.0016],myarr[{0,0},{.5,-1.03},.0016],myarr[{.5,1},{1.05,.2},.0014],myarr[{.5,-1},{1.05,-.2},.0014],alabel[labelsty[ ToString[alop]<>" insides"],.5({0,0}+{.5,1})],alabel[labelsty["join"],.5({0,0}+{.5,-1})],
alabel[labelsty[ToString[alop]],.5({.5,1}+{1.05,.2})],alabel[labelsty[ToString[alop]],.5({.5,-1}+{1.05,-.2})],
Inset[list2[{{a},{b,c}}],Scaled[{0,0}]],Inset[cartouche[{alopsingle["a"],alopdouble["b","c"]}],Scaled[{.5,1}]],Inset[cartouche[Join@@{{a,b},{c}}],Scaled[{.5,-1}]],Inset[baresty[alopright],Scaled[{1,.4}]],Inset[baresty[aloptriple],Scaled[{1,-.4}]]
},
AspectRatio->.3,ImageSize->400
]

algdiagright

Force associativity with standard notation

wp[list_]:=StringReplace[ToString[list],{"{"->"(","}"->")"}]

wp[{a,b}]

wp[{c}]

alop[list_]:=baresty["alop"<>wp[list]]

alop[{a,b}]

alop[{c}]

Join@@{{a,b},{c}}

{alop[{a,b}],alop[{c}]}

alop/@{{a,b},{c}}

alop/@{{a,b,c}}

alop[alop/@{{a,b},{c}}]

algdiag2[start_,algop_,size_]:=
Module[
{
insfirst=algop/@start,
joinedlist=Join@@start,
end1=algop@@(algop/@start),
end2=algop@@{Join@@start},
lab1=labelsty[ ToString[algop]<>" insides"],
lab2=labelsty["join"],
lab3=labelsty[ToString[algop]],
lab4=labelsty[ToString[algop]]
},
Graphics[
{Arrowheads[.03],myarr[{0,0},{.5,1.03},.0016],myarr[{0,0},{.5,-1.03},.0016],myarr[{.5,1},{1.05,.13},.0014],myarr[{.5,-1},{1.05,-.12},.0014],alabel[lab1,.5({0,0}+{.5,1})],alabel[lab2,.5({0,0}+{.5,-1})],
alabel[lab3 ,.5({.5,1}+{1.05,.15})],alabel[lab4,.5({.5,-1}+{1.05,-.15})],
Inset[list2[start],Scaled[{0,0}]],Inset[cartouche[insfirst],Scaled[{.5,1}]],Inset[cartouche[joinedlist],Scaled[{.5,-1}]],Inset[baresty[end1],Scaled[{1,.2}]],Inset[baresty[end2],Scaled[{1,-.2}]]
},
AspectRatio->.3,ImageSize->size
]
]

algdiag2[{{a,b},{c}},alop,350]

algdiag2[{{a},{b,c}},alop,350]

The monad of multisets

Show multisets

mset[list_]:=Sort[list]

mset[{6,6,3,5,4,4,7,1}]

msjoin[list_,list2_]:=mset[Join[list,list2]]

msjoin[{4,4,5,3,3,6},{2,3,7,6,5,5,5}]

The monad of sets

Show sets

sset[list_]:=Union[list]

sset[{4,4,5,3,3,6}]