Data commit

Task/Determinant-and-permanent/Haskell/determinant-and-permanent-1.hs

@@ -0,0 +1,59 @@
+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]]
+    ]

Task/Determinant-and-permanent/Haskell/determinant-and-permanent-2.hs

@@ -0,0 +1,50 @@
+outer :: (a->b->c) -> [a] -> [b] -> [[c]]
+outer f [] _       = []
+outer f _ []       = []
+outer f (h1:t1) x2 = (f h1 <$> x2) : outer f t1 x2
+
+dot [] []           = 0
+dot (h1:t1) (h2:t2) = (h1*h2) + (dot t1 t2)
+
+transpose [] = []
+transpose ([] : xss) = transpose xss
+transpose ((x:xs) : xss)
+  = (x : [h | (h:_) <- xss]) : transpose (xs : [ t | (_:t) <- xss])
+
+mul :: Num a => [[a]] -> [[a]] -> [[a]]
+mul a b = outer dot a (transpose b)
+
+delRow :: Int -> [a] -> [a]
+delRow i v =
+  (first ++ rest) where (first, _:rest) = splitAt i v
+
+delCol :: Int -> [[a]] -> [[a]]
+delCol j m = (delRow j) <$> m
+
+-- Determinant:
+adj :: Num a => [[a]] -> [[a]]
+adj [] = []
+adj m =
+  [
+    [(-1)^(i+j) * det (delRow i $ delCol j m)
+    | i <- [0.. -1+length m]
+    ]
+  | j <- [0.. -1+length m]
+  ]
+det :: Num a => [[a]] -> a
+det [] = 1
+det m  = (mul m (adj m)) !! 0 !! 0
+
+-- Permanent:
+padj :: Num a => [[a]] -> [[a]]
+padj [] = []
+padj m =
+  [
+    [perm (delRow i $ delCol j m)
+    | i <- [0.. -1+length m]
+    ]
+  | j <- [0.. -1+length m]
+  ]
+perm :: Num a => [[a]] -> a
+perm [] = 1
+perm m  = (mul m (padj m)) !! 0 !! 0