[Haskell-cafe] tensor product of dynamic-sized bits

[Ahn, Ki Yung]

For some reasons, I am trying to write a small Haskell code for tensor
products (See http://en.wikipedia.org/wiki/Tensor_product) of bits,
which can expand or shrink their size and dimension as needed.

Has anyone already done similar or more general work before? If so, I'd
be happy use/consult that and cite the work. Otherwise, I should think
about cleaning up and packaging this as a library. My code is like this
right now:

> data Bits = O         -- all 1 bits of any size and dimension
>           | I         -- all 0 bits of any size and dimension
>           | Bs [Bits] -- row of bits possibly nested
>           | Rep Bits  -- repeating of bits (e.g. O = Rep O = Bs [O,O])
>   deriving (Eq,Show)

bitwise-and

> O           .& _           = O
> _           .& O           = O
> (Rep O)     .& _           = O
> _           .& (Rep O)     = O
> (Bs (O:xs)) .& _           | all (O==) xs  = O
> _           .& (Bs (O:xs)) | all (O==) xs  = O
> I           .& y           = y
> x           .& I           = x
> (Rep I)     .& y           = y
> x           .& (Rep I)     = x
> (Bs (I:xs)) .& y           | all (I==) xs  = y
> x           .& (Bs (I:ys)) | all (I==) ys  = x
> (Bs xs)     .& (Bs ys)     = reduce $ Bs (zipWith (.&) xs ys)
> (Rep x)     .& (Bs ys)     = reduce $ Bs (xs .&. ys) where xs=repeat x
> (Bs xs)     .& (Rep y)     = reduce $ Bs (xs .&. ys) where ys=repeat y
> (Rep x)     .& (Rep y)     = reduce $ Rep (x .& y)
>
> (.&.) = zipWith (.&)

bitwise-or

> O           .| y           = y
> x           .| O           = x
> (Rep O)     .| y           = y
> x           .| (Rep O)     = x
> (Bs (O:xs)) .| y           | all (O==) xs  = y
> x           .| (Bs (O:ys)) | all (O==) ys  = x
> I           .| _           = I
> _           .| I           = I
> (Rep I)     .| _           = I
> _           .| (Rep I)     = I
> (Bs (I:xs)) .| _           | all (I==) xs  = I
> _           .| (Bs (I:ys)) | all (I==) ys  = I
> (Bs xs)     .| (Bs ys)     = reduce $ Bs (xs .|. ys)
> (Rep x)     .| (Bs ys)     = reduce $ Bs (xs .|. ys) where xs=repeat x
> (Bs xs)     .| (Rep y)     = reduce $ Bs (xs .|. ys) where ys=repeat y
> (Rep x)     .| (Rep y)     = reduce $ Rep (x .| y)
>
> (.|.) = zipWith (.|)

tensor product

> O           .* _           = O
> _           .* O           = O
> (Rep O)     .* _           = O
> _           .* (Rep O)     = O
> (Bs (O:xs)) .* _           | all (O==) xs  = O
> _           .* (Bs (O:ys)) | all (O==) ys  = O
> I           .* I           = I
> I           .* (Rep y)     = I .* y
> (Rep I)     .* y           = I .* y
> (Bs (I:xs)) .* y           | all (I==) xs  = I .* y
> I           .* y           = reduce $ Rep y
> x           .* (Rep I)     = x .* I
> x           .* (Bs (I:xs)) | all (I==) xs  = x .* I
> x           .* I           = x
> (Bs xs)     .* (Bs ys)     = reduce $ Bs (xs .*. ys)
> (Bs xs)     .* (Rep y)     = reduce $
>                              Bs (map (reduce . Rep) $ xs .*. [y])
> (Rep x)     .* y           = reduce $ Rep (x .* y)
>
> []     .*. _  = []
> (x:xs) .*. ys = (reduce $ Bs [x .* y | y<-ys]) : (xs .*. ys)

reducing  from Bs [O,O,..] to O and from Bs [I,I,..] to I

> reduce (Bs (x:xs))     | all (x==) xs = x
> reduce (Rep x@(Rep _)) = x
> reduce x               = x

Some example run on Hugs:

Main> Bs [I,O]

Bs [I,O]

Main> Bs [I,O] .| Bs [O,Bs [I,I,I,I] .* Bs [I,O,O,O,O]]

Bs [I,Rep (Bs [I,O,O,O,O])]

Main> Bs [I,O] .| Bs [O, Bs [I,I,I,I] .* Bs [I,O,O,O,O]]
               .| Bs [O, Bs [I,O,O,O] .* Bs [I,I,I,I,I]]

Bs [I,Bs [I,Bs [I,O,O,O,O],Bs [I,O,O,O,O],Bs [I,O,O,O,O]]]

Main> Bs [I,O] .| Bs [O, Bs [I,I,I,I] .* Bs [I,O,O,O,O]]
               .| Bs [O, Bs [I,O,O,O] .* Bs [I,I,I,I,I]]
               .| Bs [O, Bs [O,I,I,O] .* Bs [O,I,I,O,O]]

Bs [I,Bs [I,Bs [I,I,I,O,O],Bs [I,I,I,O,O],Bs [I,O,O,O,O]]]

Main> Bs [I,O] .| Bs [O, Bs [I,I,I,I] .* Bs [I,O,O,O,O]]
               .| Bs [O, Bs [I,O,O,O] .* Bs [I,I,I,I,I]]
               .| Bs [O, Bs [O,I,I,O] .* Bs [O,I,I,O,O]]
               .| Bs [O, Bs [O,I,I,I] .* Bs [O,O,O,I,I]]

Bs [I,Bs [I,I,I,Bs [I,O,O,I,I]]]

Main> Bs [I,O] .| Bs [O, Bs [I,I,I,I] .* Bs [I,O,O,O,O]]
               .| Bs [O, Bs [I,O,O,O] .* Bs [I,I,I,I,I]]
               .| Bs [O, Bs [O,I,I,O] .* Bs [O,I,I,O,O]]
               .| Bs [O, Bs [O,I,I,I] .* Bs [O,O,O,I,I]]
               .| Bs [O, Bs [O,O,I,I] .* Bs [O,I,I,O,O]]

I