`bar/EA` := proc ()
 local i;
 for i from 2 to nargs do
  if args[i] = 1 then return 0 fi;
 od;
 return '`bar/EA`'(args);
end:

# The standard differential in the bar complex is `d/EA`

`d/EA` := (u) -> sort(expand(eval(subs(`bar/EA`=`d_bar/EA`,u))));

`d_bar/EA` := proc()
 local n,i,q,a;
 a := args;
 n := nargs;
 if n = 0 then
  return FAIL;
 elif n = 1 then
  return 0;
 else 
  return
   add((-1)^i*`bar/EA`(a[1..i-1],a[i]*a[i+1],a[i+2..n]),i=1..n-1) +
    (-1)^n*`bar/EA`(a[1..n-1]);
 fi;
end:

# The shuffle product in the bar complex is `mu/EA`

`mu/EA` := proc()
 apply_linear_assoc(`mu0/EA`,`bar/EA`())(args);
end:

`mu0/EA` := proc(u,v)
 local n,m,uv,c,L,s,i;
 n := nops(u)-1;
 m := nops(v)-1;
 uv := [op(2..n+1,u),op(2..m+1,v)];
 c := op(1,u) * op(1,v);
 L := `list_elements/inverse_shuffles`(n,m);

 return add(`sgn/shuffles`(n,m)(s) *
             `bar/EA`(c,seq(uv[s[i]],i=1..n+m)),s in L):
end:

`mu_bar/EA` := proc()
 `mu/EA`(op(map(`bar/EA`,[args])));
end:

# We now give a chain homotopy of EA for the case where A is cyclic
# of infinite order generated by a.  This gives a retraction onto
# a subcomplex concentrated in degrees 0 and 1.

`s0/EA` := (a) -> proc(u)
 local n,k,s,i;
 if type(u,specfunc(anything,`bar/EA`)) then
  n := nops(u);
  if n <= 1 then return 0; fi;
  k := degree(op(n,u),a);
  if op(n,u) <> a^k then
   return FAIL;
  fi;
  if k >= 0 then 
   return add((-1)^n*`bar/EA`(op(1..n-1,u),a^i,a),i=0..k-1);
  else
   return add((-1)^(n+1)*`bar/EA`(op(1..n-1,u),a^(-i),a),i=1..abs(k));
  fi:
 else
  return FAIL;
 fi;
end:

`s/EA` := (a) -> apply_linear(`s0/EA`(a));

`p0/EA` := (a) -> proc(u)
 local n,i,k;
 if type(u,specfunc(anything,`bar/EA`)) then
  n := nops(u);
  if n <= 1 then
   return u;
  elif n = 2 then
   k := degree(op(2,u),a);
   if op(n,u) <> a^k then
    return FAIL;
   fi;
   if k >= 0 then
    return add(`bar/EA`(a^i*op(1,u),a),i=0..k-1);
   else
    return add(-`bar/EA`(a^(-i)*op(1,u),a),i=1..abs(k));
   fi;
  else
   return 0;
  fi;
 else
  return FAIL;
 fi;

end:

`p/EA` := (a) -> apply_linear(`p0/EA`(a));


######################################################################

# Given elements a[i] in A we have elements 1 - a[i] in the group ring.
# The tensor product of these is represented by `bar/BA`(a[1],...,a[n])

`bar/BA` := proc ()
 local i;
 for i to nargs do
  if args[i] = 1 then return 0 fi;
 od;
 return '`bar/BA`'(args);
end:

# The standard differential in the bar complex is `d/BA`

`d/BA` := (u) -> sort(expand(eval(subs(`bar/BA`=`d_bar/BA`,u))));

`d_bar/BA` := proc()
 local n,i,q;
 n := nargs;
 if n = 0 then
  return 0;
 else 
  return -`bar/BA`(args[2..n]) + 
         (-1)^(n+1)*`bar/BA`(args[1..n-1]) +
         add((-1)^(i+1)*`bar/BA`(args[1..i-1],args[i]*args[i+1],args[i+2..n]),
             i=1..n-1);
 fi;
end:

# The shuffle product in the bar complex is `mu/BA`

`mu/BA` := proc()
 apply_linear_assoc(`mu0/BA`,`bar/BA`())(args);
end:

`mu0/BA` := proc(u,v)
 local n,m,uv,L,s,i;
 n := nops(u);
 m := nops(v);
 uv := [op(u),op(v)];
 L := `list_elements/inverse_shuffles`(n,m);

 return add(`sgn/shuffles`(n,m)(s) * `bar/BA`(seq(uv[s[i]],i=1..n+m)),s in L):
end:

`mu_bar/BA` := proc()
 `mu/BA`(op(map(`bar/BA`,[args])));
end:

`proj_bar/EA` := proc() `bar/BA`(args[2..-1]); end:
`lift_bar/BA` := proc() `bar/EA`(1,args); end: 
`proj/EA/BA` := (u) -> eval(subs(`bar/EA` = `proj_bar/EA`,u));
`lift/BA/EA` := (u) -> eval(subs(`bar/BA` = `lift_bar/BA`,u));

######################################################################
# The element u = `tau/BA`(n,a) has du = n[a] - [a^n].
# Thus, if a^n = 1 then u is a 2-cycle modulo n.

`tau/BA` := proc(n,a)
 local k;
 add(-`bar/BA`(a^k,a),k=0..n-1);
end:

`zeta/BA` := proc(n,m,a)
 local i,j;
 - add(add(`bar/BA`(a^(m*i),a^j,a),j=0..m-1),i=0..n-1);
end:

# The element `sigma/BA`(n,a,b) is a chain of dimension 3.
# It is symmetric in a and b, and is a cycle if a^n = b^n = 1.

`sigma/BA` := proc(n,a,b)
 `mu/BA`(`tau/BA`(n, a), `bar/BA`(b)) +
 `mu/BA`(`tau/BA`(n, b), `bar/BA`(a))
end:

# The element u = `gamma/BA`(n,a) is a chain of dimension 2n+1.
# It is a cycle if a^n = 1.

`gamma/BA` := proc(n,k,a)
 local u,v,i;
 u := `bar/BA`(a);
 v := `tau/BA`(n,a);
 for i from 1 to k do
  u := `mu/BA`(u,v);
 od;
 u := expand(u/k!);
 return u;
end:

`xi/BA` := proc(n,m,a)
 local i,j;
 
 add(add(-`bar/BA`(a^i,a,a^j,a),i=1..m-1),j=1..n*m-1) +
 add(add(-`bar/BA`(a^m,a^(i*m),a^j,a),j=1..m-1),i=1..n-1);
end:

`rho/BA` := proc(n,a,b)
 `tau/BA`(n,a) +
 `tau/BA`(n,b) -
 `tau/BA`(n,a*b) +
 n*`bar/BA`(a, b);
end:

`omega/BA` := proc (n,a,b)
 local i,j;
 
 -add(add(`bar/BA`(a^i*b^j,b,a), j = i .. n-1), i = 0 .. n-1) +
  add(add(`bar/BA`(a^i*b^j,a,b), j = i+1 .. n-1), i = 0 .. n-2);
end:

######################################################################
# We now introduce the standard DGA for H_*(BZ/n).

# The k'th chain group is freely generated over Z[Z/n] by
# `e/EC`(n)(k,0).  The orbit of this consists of elements `e/EC`(n)(k,i).

`de/EC` := (n::posint) -> proc(k::nonnegint,i::nonnegint)
 local j;
 
 if k = 0 then
  return 0;
 elif modp(k,2) = 0 then
  return(add(`e/EC`(n)(k-1,j),j=0..n-1));
 else
  return `e/EC`(n)(k-1,modp(i+1,n)) - `e/EC`(n)(k-1,i);
 fi;
end:

`d/EC` := (n) -> (u) -> eval(subs(`e/EC` = `de/EC`,u));

`mu/EC` := (n) -> proc()
 apply_linear_assoc(`mu0/EC`(n),`e/EC`(n)(0,0))(args);
end:

`mu0/EC` := (n) -> proc(a,b)
 local ka,kb,ia,ib,la,lb;
 if type(a,specfunc(anything,`e/EC`(n))) and
    type(b,specfunc(anything,`e/EC`(n))) then
  ka,ia := op(a);
  kb,ib := op(b);
  if modp(ka,2) = 1 and modp(kb,2) = 1 then
   return 0;
  fi;
  la := floor(ka/2);
  lb := floor(kb/2);
  return binomial(la+lb,la) * `e/EC`(n)(ka+kb,modp(ia+ib,n));
 else
  return('`mu/EC`'(n)(args))
 fi;
end:


##################################################

`de/BC` := (n::posint) -> proc(k::nonnegint)
 if k = 0 or modp(k,2) = 1 then
  return 0;
 else
  return n * `e/BC`(n)(k-1);
 fi;
end:

`d/BC` := (n) -> (u) -> eval(subs(`e/BC` = `de/BC`,u));

`mu/BC` := (n) -> proc()
 apply_linear_assoc(`mu0/BC`(n),`e/BC`(n)(0))(args);
end:

`mu0/BC` := (n) -> proc(a,b)
 local ka,kb,la,lb;
 if type(a,specfunc(anything,`e/BC`(n))) and
    type(b,specfunc(anything,`e/BC`(n))) then
  ka := op(a);
  kb := op(b);
  if modp(ka,2) = 1 and modp(kb,2) = 1 then
   return 0;
  fi;
  la := floor(ka/2);
  lb := floor(kb/2);
  return binomial(la+lb,la) * `e/BC`(n)(ka+kb);
 else
  return('`mu/BC`'(n)(args))
 fi;
end:

`e/BC/BA` := (n::posint) -> proc(k::nonnegint)
 option remember;

 if k = 0 then
  return `bar/BA`();
 elif k = 1 then
  return `bar/BA`(a);
 else
  return expand(`mu/BA`(`tau/BA`(n,a),`e/BC/BA`(n)(k-2))/floor(k/2));
 fi;
end:

`phi/BC/BA` := proc(u)
 eval(subs(`e/BC` = `e/BC/BA`,u));
end:

######################################################################

check_homology_BA := proc()
 local i,j,k,n,m,a,b,c,t,u,v,w,T,ok,err,exp_rel,diff_rel;

 ok := true;
 for i from 0 to 4 do
  for j from 0 to 4 do 
   u := `bar/EA`(seq(a[m],m=1..i+1)); 
   v := `bar/EA`(seq(a[m],m=i+2..i+j+2));
   err := `mu/EA`(u,v) - (-1)^(i*j) * `mu/EA`(v,u);
   if err <> 0 then
    ok := false;
    break;
   fi;
  od:
  if not(ok) then break; fi;
 od:

 _ASSERT(ok,"`mu/EA` is graded-commutative");

 ok := true;
 for i from 0 to 4 do
  for j from 0 to 4 do 
   for k from 0 to 4 do 
    u := `bar/EA`(seq(a[m],m=1..i+1)); 
    v := `bar/EA`(seq(a[m],m=i+2..i+j+2));
    w := `bar/EA`(seq(a[m],m=i+j+3..i+j+k+3));
    err := `mu/EA`(`mu/EA`(u,v),w) - `mu/EA`(u,`mu/EA`(v,w));
    if err <> 0 then
     ok := false;
     break;
    fi;
   od:
   if not(ok) then break; fi;
  od:
  if not(ok) then break; fi;
 od:

 _ASSERT(ok,"`mu/EA` is associative");

 ok := true;
 for i from 0 to 3 do
  for j from 0 to 3 do 
   u := `bar/EA`(seq(a[m],m=1..i+1)); 
   v := `bar/EA`(seq(a[m],m=i+2..i+j+2));
   err := `d/EA`(`mu/EA`(u,v)) - `mu/EA`(`d/EA`(u),v) - (-1)^i*`mu/EA`(u,`d/EA`(v));
   if err <> 0 then
    ok := false;
    break;
   fi;
  od:
  if not(ok) then break; fi;
 od:

 _ASSERT(ok,"`d/EA` and `mu/EA` satisfy the Leibniz rule");

 ok := true;
 for i from 0 to 4 do
  for j from 0 to 4 do 
   u := `bar/BA`(seq(a[m],m=1..i)); 
   v := `bar/BA`(seq(a[m],m=i+1..i+j));
   err := `mu/BA`(u,v) - (-1)^(i*j) * `mu/BA`(v,u);
   if err <> 0 then
    ok := false;
    break;
   fi;
  od:
  if not(ok) then break; fi;
 od:

 _ASSERT(ok,"`mu/BA` is graded-commutative");

 ok := true;
 for i from 0 to 4 do
  for j from 0 to 4 do 
   for k from 0 to 4 do 
    u := `bar/BA`(seq(a[m],m=1..i)); 
    v := `bar/BA`(seq(a[m],m=i+1..i+j));
    w := `bar/BA`(seq(a[m],m=i+j+1..i+j+k));
    err := `mu/BA`(`mu/BA`(u,v),w) - `mu/BA`(u,`mu/BA`(v,w));
    if err <> 0 then
     ok := false;
     break;
    fi;
   od:
   if not(ok) then break; fi;
  od:
  if not(ok) then break; fi;
 od:

 _ASSERT(ok,"`mu/BA` is associative");

 ok := true;
 for i from 0 to 4 do
  for j from 0 to 4 do 
   u := `bar/BA`(seq(a[m],m=1..i)); 
   v := `bar/BA`(seq(a[m],m=i+1..i+j));
   err := `d/BA`(`mu/BA`(u,v)) - `mu/BA`(`d/BA`(u),v) - (-1)^i*`mu/BA`(u,`d/BA`(v));
   if err <> 0 then
    ok := false;
    break;
   fi;
  od:
  if not(ok) then break; fi;
 od:

 _ASSERT(ok,"`d/BA` and `mu/BA` satisfy the Leibniz rule");

 n := 5;
 err := `d/BA`(`tau/BA`(n,a)) - n * `bar/BA`(a);
 exp_rel := `bar/BA`(a^n);
 err := err + exp_rel;
 
 _ASSERT(err = 0,"d(tau_n(a))");

 err := 
  `d/BA`(`mu/BA`(`tau/BA`(n,a),`bar/BA`(b))) - n * `mu_bar/BA`(a,b);
 exp_rel := `mu_bar/BA`(a^n,b); 
 err := err + exp_rel;

 _ASSERT(err = 0,"d(tau_n(a) b)");

 _ASSERT(
  {seq(seq(
   `tau/BA`(i*j,a) - `tau/BA`(i,a^j) - i * `tau/BA`(j,a) - `d/BA`(`zeta/BA`(i,j,a)),
  j=1..4),i=1..4)} = {0},
  "tau_{ij}(a)"
 );

 err := `d/BA`(`sigma/BA`(n,a,b));
 exp_rel := `mu_bar/BA`(a^n,b) - `mu_bar/BA`(a,b^n);
 err := err + exp_rel;

 _ASSERT(err = 0,"d(sigma_n(a,b))");

 _ASSERT(`sigma/BA`(n,a,b) = `sigma/BA`(n,b,a),"sigma_n is symmetric");
 
 err :=
  `sigma/BA`(n,a,b*c) - `sigma/BA`(n,a,b) - `sigma/BA`(n,a,c) +
    `mu/BA`(`bar/BA`(a),`rho/BA`(n,b,c));
 diff_rel := - `mu/BA`(`tau/BA`(n,a),`bar/BA`(b,c));
 exp_rel  := - `mu/BA`(`bar/BA`(a^n),`bar/BA`(b,c));
 err := err + `d/BA`(diff_rel) + exp_rel;

 _ASSERT(err = 0,"First formula for sigma_n(a,bc)");

 err := 
  `sigma/BA`(n,a,b*c)-`sigma/BA`(n,a,b)-`sigma/BA`(n,a,c)+
   binomial(n+1,2)*`mu_bar/BA`(a,b,c);
   
 diff_rel := -(`mu/BA`(`bar/BA`(a),`omega/BA`(n,b,c))+
  	       `mu/BA`(`tau/BA`(n,a),`bar/BA`(b,c)));
 exp_rel := 
  - `mu/BA`(`bar/BA`(a^n),`bar/BA`(b,c)) - 
  add(`bar/BA`(a,b^i,b)-`bar/BA`(a,b^i*c^n,b),i=0..n-1)- 
  add(`bar/BA`(b^i,b,a)-`bar/BA`(b^i*c^n,b,a),i=0..n-1)+
  add(`bar/BA`(b^i,a,b)-`bar/BA`(b^i*c^n,a,b),i=0..n-1);

 err := err + `d/BA`(diff_rel) + exp_rel;

 _ASSERT(err = 0,"Second formula for sigma_n(a,bc)");

 for k from 1 to 5 do
  err := `d/BA`(`gamma/BA`(n,k,a));
  T := [[]]:
  for i from 1 to k-1 do
   T := [seq(seq([op(t),a,a^j],j=1..n-1),t in T)]:
  od:
  exp_rel := (-1)^k*add(`mu/BA`(`bar/BA`(op(t),a),`bar/BA`(a^n)),t in T);
  err := err + exp_rel;
  _ASSERT(err = 0,sprintf("d(gamma_{n,%d}(u))",k));
 od:

 _ASSERT(simplify(`sigma/BA`(n,a,a) - 2 * `gamma/BA`(n,1,a)) = 0,
         "sigma_n(a,a) = 2 gamma_{n,1}(a)");
	 
 err := 
  `gamma/BA`(n,1,a*b) - `gamma/BA`(n,1,a) - `gamma/BA`(n,1,b) -
    `sigma/BA`(n,a,b);

 diff_rel :=
  n*`bar/BA`(a,b,a,b) -
  `mu/BA`(`bar/BA`(a,b),`tau/BA`(n,a*b)) +
  `mu/BA`(`omega/BA`(n,a,b),`bar/BA`(a)+`bar/BA`(b));
  
 exp_rel := 
  add(`bar/BA`(a^i,b,a) - `bar/BA`(a^i*b^n,b,a),i=0..n-1) -
  add(`bar/BA`(a^i,a,b) - `bar/BA`(a^i*b^n,a,b),i=0..n-1) -
  add(`bar/BA`(b,a^i,a) - `bar/BA`(b,a^i*b^n,a),i=0..n-1) -
  add(`bar/BA`(a,a^i,a) - `bar/BA`(a,a^i*b^n,a),i=0..n-1) -
 `mu/BA`(`bar/BA`(a^n*b^n),`bar/BA`(a,b));

 err := err + `d/BA`(diff_rel) + exp_rel;

 _ASSERT(err = 0,"gamma_{n,1}(ab)");

  _ASSERT(
  {seq(seq(
   `gamma/BA`(i,1,a^j) - j * `gamma/BA`(i*j,1,a) +
   `mu/BA`(`bar/BA`(a^(i*j)),`tau/BA`(j,a)) -
   `d/BA`(`xi/BA`(i,j,a)),
  j=1..4),i=1..4)} = {0},
  "gamma_{ij,1}(a)"
 );
end:

######################################################################

check_homology_BZ := proc()
 local U,i,j,u,du,sdu,su,dsu,pu,ok,err;
 
 U := [seq(`bar/EA`(a^j),j=-2..2)]:
 for i from 1 to 4 do
  U := [op(U),
	seq(seq(`bar/EA`(op(u),a^j),j=1..2),u in U),
	seq(seq(`bar/EA`(op(u),a^(-j)),j=1..2),u in U)]:
 od:

 ok := true;
 
 for u in U do
  du := `d/EA`(u);
  sdu := `s/EA`(a)(du);
  su := `s/EA`(a)(u); 
  dsu := `d/EA`(su);
  pu := `p/EA`(a)(u);
  err := sdu + dsu - u + pu;
  if err <> 0 then
   ok := false;
   break;
  fi;
 od:

 _ASSERT(ok,"ds + ds = 1 - p",[u,du,sdu,su,dsu,pu]);
end:

######################################################################

check_homology_BC := proc()
 local n,ok,u,v,w,ku,kv,kw,err;
 
 n := 5;

 ok := true;
 for ku from 0 to 4 do
  for kv from 0 to 4 do
   u := `e/BC`(n)(ku);
   v := `e/BC`(n)(kv);
   err := `mu/BC`(n)(u,v) - (-1)^(ku*kv) * `mu/BC`(n)(v,u);
   if err <> 0 then
    ok := false;
    break;
   fi;
  od:
  if not(ok) then break; fi;
 od:

 _ASSERT(ok,"`mu_BC` is graded-commutative");

 ok := true;
 for ku from 0 to 4 do
  for kv from 0 to 4 do
   for kw from 0 to 4 do
    u := `e/BC`(n)(ku);
    v := `e/BC`(n)(kv);
    w := `e/BC`(n)(kw);
    err := `mu/BC`(n)(`mu/BC`(n)(u,v),w) - `mu/BC`(n)(u,`mu/BC`(n)(v,w));
    if err <> 0 then
     ok := false;
     break;
    fi;
   od:
   if not(ok) then break; fi;
  od:
 od:
 
 _ASSERT(ok,"`mu_BC` is associative",[u,v,w,err]);

 ok := true;
 for ku from 0 to 4 do
  for kv from 0 to 4 do
   u := `e/BC`(n)(ku);
   v := `e/BC`(n)(kv);
   err := `d/BC`(n)(`mu/BC`(n)(u,v)) - `mu/BC`(n)(`d/BC`(n)(u),v) - (-1)^ku * `mu/BC`(n)(u,`d/BC`(n)(v));
   if err <> 0 then
    ok := false;
    break;
   fi;
  od:
  if not(ok) then break; fi;
 od:

 _ASSERT(ok,"Leibniz rule for BC");
end:
