RosettaCodeData/Task/Matrix-arithmetic/Haskell/matrix-arithmetic.hs

sPermutations :: [a] -> [([a], Int)]
sPermutations = flip zip (cycle [1, -1]) . foldl aux [[]]
  where
    aux items x = do
      (f, item) <- zip (cycle [reverse, id]) items
      f (insertEv x item)
    insertEv x [] = [[x]]
    insertEv x l@(y:ys) = (x : l) : ((y :) <$>) (insertEv x ys)

elemPos :: [[a]] -> Int -> Int -> a
elemPos ms i j = (ms !! i) !! j

prod
  :: Num a
  => ([[a]] -> Int -> Int -> a) -> [[a]] -> [Int] -> a
prod f ms = product . zipWith (f ms) [0 ..]

sDeterminant
  :: Num a
  => ([[a]] -> Int -> Int -> a) -> [[a]] -> [([Int], Int)] -> a
sDeterminant f ms = sum . fmap (\(is, s) -> fromIntegral s * prod f ms is)

determinant
  :: Num a
  => [[a]] -> a
determinant ms =
  sDeterminant elemPos ms . sPermutations $ [0 .. pred . length $ ms]

permanent
  :: Num a
  => [[a]] -> a
permanent ms =
  sum . fmap (prod elemPos ms . fst) . sPermutations $ [0 .. pred . length $ ms]

-- TEST -----------------------------------------------------------------------
result
  :: (Num a, Show a)
  => [[a]] -> String
result ms =
  unlines
    [ "Matrix:"
    , unlines (show <$> ms)
    , "Determinant:"
    , show (determinant ms)
    , "Permanent:"
    , show (permanent ms)
    ]

main :: IO ()
main =
  mapM_
    (putStrLn . result)
    [ [[5]]
    , [[1, 0, 0], [0, 1, 0], [0, 0, 1]]
    , [[0, 0, 1], [0, 1, 0], [1, 0, 0]]
    , [[4, 3], [2, 5]]
    , [[2, 5], [4, 3]]
    , [[4, 4], [2, 2]]
    ]