matrix.hs

{-# LANGUAGE PolyKinds, GADTs, StandaloneDeriving, UndecidableInstances, FunctionalDependencies, FlexibleContexts, MultiParamTypeClasses, ConstraintKinds, DataKinds, TypeOperators, FlexibleInstances, Rank2Types, ScopedTypeVariables #-}
import Prelude hiding (id, (.))
import Data.Monoid
import Data.Extensible -- extensible
import Data.Extensible.Dictionary
import Data.Extensible.Internal
import Data.Extensible.Internal.Rig

import GHC.Prim

class Freely x
instance Freely x

class Category cxt (k :: kind -> kind -> *) | k -> cxt where
  id :: cxt a => k a a
  (.) :: cxt c => k b c -> k a b -> k a c

class Category cxt k => Monoidal cxt k where
  zeroCat :: (cxt a, cxt b) => k a b
  (<+>) :: (cxt a, cxt b) => k a b -> k a b -> k a b

class Category cxt k => Transposing cxt k where
  transpose :: (cxt a, cxt b) => k a b -> k b a

instance Category Freely (->) where
  id x = x
  f . g = \x -> f (g x)

---------------------------------------------------------------------------------------------

newtype Row k xs c = Row (k c :* xs)

instance (Generate xs, Monoidal Freely k) => Monoid (Row k xs c) where
  mempty = Row $ generate $ const zeroCat
  mappend (Row a) (Row b) = Row $ hzipWith (<+>) a b

newtype Matrix k xs ys = Matrix { getRows :: Row k ys :* xs }

instance (Monoidal Freely k) => Category Generate (Matrix k) where
  id = Matrix $ generate $ \pos -> Row $ generate $ \p -> case compareMembership pos p of
    Right Refl -> id
    _ -> zeroCat
  Matrix g . Matrix f = Matrix $ hmap (\(Row r) -> hfoldMap getConst'
    $ hzipWith (\x (Row y) -> Const' $ Row $ hmap (.x) y) r g) f where

instance (Monoidal Freely k, Transposing Freely k) => Transposing Generate (Matrix k) where
  transpose (Matrix t) = Matrix $ generate $ \pos -> Row $ hmap (\(Row xs) -> transpose $ hlookup pos xs) t

--------------------------------------------------------------------------------

newtype Elem a i j = E a deriving (Show, Eq, Ord)

instance Num a => Category Freely (Elem a) where
  id = E 1
  E a . E b = E (a * b)

instance Num a => Monoidal Freely (Elem a) where
  E a <+> E b = E (a + b)
  zeroCat = E 0

instance Num a => Transposing Freely (Elem a) where
  transpose (E a) = E a

m23 :: Num a => Matrix (Elem a) '["first row", "second row"] '["0", "1", "2"]
m23 = Matrix $ Row (E 1 <: E 2 <: E 3 <: Nil)
   <: Row (E 4 <: E 5 <: E 6 <: Nil)
   <: Nil

m32 :: Num a => Matrix (Elem a) '["0", "1", "2"] '["c1", "c2"]
m32 = Matrix $ Row (E 1 <: E 2 <: Nil)
   <: Row (E 3 <: E 4 <: Nil)
   <: Row (E 4 <: E 5 <: Nil)
   <: Nil

-- >>> m23 !*! m32
-- 19 25
-- 43 58

(!*!) :: (Category cxt k, cxt c) => k a b -> k b c -> k a c
(!*!) = flip (.)

instance Show a => Show (Matrix (Elem a) xs ys) where
  show (Matrix rs) = hfoldMap (\(Row xs) -> hfoldMap (\(E x) -> show x ++ "\t") xs ++ "\n") rs