-- Алгебраическая структура Кольцо
class Ring a where
    add :: a -> a -> a -- (+)
    mul :: a -> a -> a -- (*)
    neg :: a -> a     -- -x
    idPlus :: () -> a -- (+) identity
    idMul :: () -> a  -- (*) identity

    minus :: a -> a -> a
    -- x - y = x + (-y)
    minus x y = add x (neg y)

-- Задаём кольцо из целых чисел (underlying set = Z)
-- С бинарными операциями + и *
instance Ring Int where
     add = (+)
     mul = (*)
     neg x = -x
     idPlus () = 0
     idMul () = 1

-- Аналогичное кольцо из рациональных чисел
instance Ring Float where
     add = (+)
     mul = (*)
     neg x = -x
     idPlus () = 0.0
     idMul () = 1.0

-- Матрица из элементов кольца
-- Можно добавить | Zero и | One для умножения и сложения
newtype Matrix a = Matrix [[a]]
    deriving Show

linearize :: Matrix a -> [a]
linearize (Matrix list) = foldl' (\ state elem -> state ++ elem) [] list

-- Выполнить операцию op над всеми элементами матриц попарно
mPerformOp :: (Ring a) => (a -> a -> a) -> Matrix a -> Matrix a -> Matrix a
mPerformOp op (Matrix a) (Matrix b) =
    Matrix result
    where
        helper [] _ = []
        helper _ [] = []
        helper (x : xs) (y : ys) = (zipWith op x y) : (helper xs ys)
        result = helper a b

-- Сложение матриц
mAdd ::(Ring a) => Matrix a -> Matrix a -> Matrix a
mAdd = mPerformOp add

-- Вычитание матриц
mSub ::(Ring a) => Matrix a -> Matrix a -> Matrix a
mSub = mPerformOp minus

-- Умножение на скаляр - матрица * скаляр
mMulR :: (Ring a) => Matrix a -> a -> Matrix a
mMulR (Matrix []) _ = Matrix []
mMulR (Matrix m) scalar =
    Matrix result
    where
        helper [] = []
        helper (x:xs) =  map (\ elem -> mul elem scalar) x : helper xs
        result = helper m

-- скаляр * матрицу
mMulL :: (Ring a) => a -> Matrix a -> Matrix a
mMulL _ (Matrix []) = Matrix []
mMulL scalar (Matrix m) =
    Matrix result
    where
        helper [] = []
        helper (x:xs) =  map (\ elem -> mul scalar elem) x : helper xs
        result = helper m

-- (- Матрица)
mNeg :: (Ring a) => Matrix a -> Matrix a
mNeg (Matrix []) = Matrix []
mNeg (Matrix m) =
    Matrix result
    where
        helper [] = []
        helper (x:xs) =  map (\ elem -> neg elem) x : helper xs
        result = helper m

-- Транспозиция
mTranspose :: (Ring a) => Matrix a -> Matrix a
mTranspose (Matrix m) = Matrix (transpose m)

summator :: (Ring a) => [a] -> a
summator list = foldl' add (idPlus()) list

-- Умножение матриц
mMul :: (Ring a) => Matrix a -> Matrix a -> Matrix a
mMul (Matrix aM) (Matrix bM) =
    Matrix [ [summator $ zipWith mul a b | b <- transpose bM ] | a <- aM ]

-- Нулевая матрица
mZero :: (Ring a) => () -> Matrix a
mZero () = Matrix [[ idPlus() ]]

-- Единичная матрица
mOne :: (Ring a) => () -> Matrix a
mOne () = Matrix [[ idMul() ]]

-- Матрицы тоже образуют кольцо
instance Ring a => Ring (Matrix a) where
    add = mAdd
    mul = mMul
    neg = mNeg
    idPlus = mZero
    idMul = mOne

-- Выражение в кольце
data (Ring a) => Expression a =
    Element a
    | Plus (Expression a) (Expression a)
    | Minus (Expression a) (Expression a)
    | Negate (Expression a)
    | Mul (Expression a) (Expression a)
    | Zero
    | One
    deriving Show

-- Функция, вычисляющая значение выражения
calc :: (Ring a) => Expression a -> a
calc (Element x) = x
calc (Plus e1 e2) = add (calc e1) (calc e2)
calc (Minus e1 e2) = minus (calc e1) (calc e2)
calc (Negate e1) = neg (calc e1)
calc (Mul e1 e2) = mul (calc e1) (calc e2)
calc Zero = idPlus ()
calc One = idMul ()


-- Тестовые данные
a_m = Matrix [[1, 3], [2, 4], [0, 5]] :: Matrix Int
b_m = Matrix [[1, 0], [2, 3]]
i_m = Matrix [[1, 0, 0, 1], [0, 1, 0, 1]]

megaMatrix = Matrix [[ a_m, b_m, a_m], [i_m, a_m, b_m]]

test = mMul a_m b_m
test2 = mMul test i_m

-- Выражения
e = Negate (Mul (Element a_m) (Element b_m))
e1 = Mul (Plus One (One :: Expression Float)) One


main =
    do
        putStrLn $ show test
        putStrLn $ show test2
        putStrLn $ show $ megaMatrix
        putStrLn $ show $ mMulR megaMatrix a_m
        putStrLn $ show $ mNeg megaMatrix
        putStrLn $ show $ calc e
        putStrLn $ show $ calc e1