BeginPackage["NonCommutativeMultiply`"]


Unprotect[NonCommutativeMultiply]
 
 CommutativeQ::usage = "CommutativeQ[x] is True if x is commutative
 (the default), and False if x is non-commutative."
 
 SetNonCommutative::usage = "SetNonCommutative[a, b, c, ...] sets
 the symbols a, b, c, ... to be non-commutative."
 
 CommutativeAllQ::usage = "CommutativeAllQ[expr] is True if expr does not
 have any non-commuting sub-expressions, and False otherwise."
 
 Commutator::usage = "Commutator[a, b] is an equivalent expression to
 a**b, with a and b interchanged (e.g. Commutator[a, b] = b**a + [a, b])."
 
 Commute::usage = "Commute[expr, {x, y}] commutes y from the right of
x to the left of x everywhere in expr."

 NonCommutativeExpand::usage = "NonCommutativeExpand[expr] expands
  NonCommutativeMultiply of sums."
SetAttributes[NonCommutativeExpand, Listable]

 NonCommutativeFactor::usage = "NonCommutativeFactor[expr] attempts
 to factor sums of NonCommutativeMultiply's."
SetAttributes[NonCommutativeFactor, Listable]

(*
CollectWithoutExpanding::usage = "CollectWithoutExpanding[expr, x]
is the same as Collect[expr, x], except no unnecessary expansion takes
place (e.g. Collect[(a+b)^2 x, x] -> (a^2+2a b+b^2) x, whereus
CollectWithoutExpanding[(a+b)^2 x, x] -> (a+b)^2 x)"
*)

ClearAttributes[NonCommutativeMultiply, {OneIdentity, Flat}]
 
(* **************************************************************** *)

Begin["`Private`"];

(* **************************************************************** *)

CommutativeQ[_] := True
 
(* **************************************************************** *)

CommutativeAllQ[s_Symbol] := CommutativeQ[s]
CommutativeAllQ[x_] := False /; !CommutativeQ[x]
CommutativeAllQ[c_?NumberQ] := True
CommutativeAllQ[f_[x___]] := CommutativeQ[f] &&
 And @@ (CommutativeAllQ /@ {x})
 
(* **************************************************************** *)

SetNonCommutative[a__] :=
 (Function[x, CommutativeQ[x] = False; CommutativeQ[x[___]] = False] /@ {a});
 
(* **************************************************************** *)

Literal[NonCommutativeMultiply[a___, NonCommutativeMultiply[b__], c___]] :=
 NonCommutativeMultiply[a, b, c]

Literal[NonCommutativeMultiply[a___, b_ c_, d___]]:=
 b NonCommutativeMultiply[a, c, d] /; CommutativeAllQ[b]

Literal[NonCommutativeMultiply[a___, b_, c___]] :=
 b NonCommutativeMultiply[a, c] /; CommutativeAllQ[b]

Literal[NonCommutativeMultiply[a_]] := a

NonCommutativeMultiply[] := 1

(* **************************************************************** *)

NonCommutativeExpand[expr_] :=
 expr //. Literal[NonCommutativeMultiply[a___, b_Plus, c___]] :>
 (NonCommutativeMultiply[a, #, c]& /@ b)

(* **************************************************************** *)

CollectWithoutExpanding[expr_, f_] := 
Release[Collect[expr /. f x_ :> f Hold[x], f]]

(* **************************************************************** *)

NonCommutativeFactor[expr_?(FreeQ[#, NonCommutativeMultiply]&)] := expr

NonCommutativeFactor[expr_] :=
CollectWithoutExpanding[expr, NonCommutativeMultiply] //. {
  a_. Literal[NonCommutativeMultiply[b_, c__]] + 
   d_. Literal[NonCommutativeMultiply[b_, e__]] :>
    NonCommutativeMultiply[b, a NonCommutativeMultiply[c] +
	d NonCommutativeMultiply[e]] /; FreeQ[{a, d}, NonCommutativeMultiply],
  a_. Literal[NonCommutativeMultiply[b__, c_]] +
    d_. Literal[NonCommutativeMultiply[e__, c_]] :>
	NonCommutativeMultiply[a NonCommutativeMultiply[b] +
      d NonCommutativeMultiply[e], c]/; FreeQ[{a, d}, NonCommutativeMultiply]
}


(* **************************************************************** *)

Commute[expr_, {a_, b_}] :=
 expr /. Literal[NonCommutativeMultiply[f___, a, b, g___]] :>
  NonCommutativeMultiply[f, Commutator[a, b], g]

(* **************************************************************** *)

Commutator[x_, x_] := x ** x

(* **************************************************************** *)

End[]

EndPackage[]
