Data commit

Task/Kaprekar-numbers/Haskell/kaprekar-numbers-1.hs

@@ -0,0 +1,42 @@
+import Text.Printf (printf)
+import Data.Maybe (mapMaybe)
+import Numeric (showIntAtBase)
+
+kaprekars :: Integer -> Integer -> [(Integer, Integer, Integer)]
+kaprekars base top = (1, 0, 1) : mapMaybe kap (filter res [2 .. top])
+  where
+    res x = x * (x - 1) `mod` (base - 1) == 0
+    kap n =
+      getSplit $
+      takeWhile (<= nn) $ dropWhile (< n) $ iterate (* toInteger base) 1
+      where
+        nn = n * n
+        getSplit [] = Nothing
+        getSplit (p:ps)
+          | p == n = Nothing
+          | q + r == n = Just (n, q, r)
+          | r > n = Nothing
+          | otherwise = getSplit ps
+          where
+            (q, r) = nn `divMod` p
+
+heading :: Int -> String
+heading = printf (h ++ d)
+  where
+    h = " #    Value (base 10)         Sum (base %d)             Square\n"
+    d = " -    ---------------         -------------             ------"
+
+printKap :: Integer -> (Int, (Integer, Integer, Integer)) -> String
+printKap b (i, (n, l, r)) =
+  printf "%2d %13s %26s %16s" i (show n) ss (base b (n * n))
+  where
+    ss = base b n ++ " = " ++ base b l ++ " + " ++ base b r
+    base b n = showIntAtBase b (("0123456789" ++ ['a' .. 'z']) !!) n ""
+
+main :: IO ()
+main = do
+  putStrLn $ heading 10
+  mapM_ (putStrLn . printKap 10) $ zip [1 ..] (kaprekars 10 1000000)
+  putStrLn ""
+  putStrLn $ heading 17
+  mapM_ (putStrLn . printKap 17) $ zip [1 ..] (kaprekars 17 1000000)

Task/Kaprekar-numbers/Haskell/kaprekar-numbers-2.hs

@@ -0,0 +1,50 @@
+import Control.Monad (foldM, join)
+import Data.List (group, nub, sort)
+
+primes :: [Int]
+primes = 2 : 3 : filter isPrime (scanl (+) 5 $ cycle [2, 4])
+  where
+    isPrime x = all ((0 /=) . mod x) $ takeWhile ((<= x) . join (*)) primes
+
+unitFactors :: Int -> [Int]
+unitFactors n = map product $ group $ f n $ takeWhile ((<= n) . join (*)) primes
+  where
+    f 1 [] = []
+    f n [] = [n]
+    f n (p:ps)
+      | n `mod` p == 0 = p : f (n `div` p) (p : ps)
+      | otherwise = f n ps
+
+-- all factors x of n where x and n/x are coprime
+factors :: Int -> [Int]
+factors = foldM f 1 . unitFactors
+  where
+    f x a = [x, x * a]
+
+-- modulo multiplication inverse: returns a where a x + b y == 1
+inverse :: Int -> Int -> Int
+inverse x y =
+  if a < 0
+    then a + y
+    else a
+  where
+    (a, b) = extEuclid x y
+    extEuclid _ 0 = (1, 0)
+    extEuclid x y = (t, s - q * t)
+      where
+        (s, t) = extEuclid y r
+        (q, r) = x `divMod` y
+
+kaprekars :: Int -> Int -> [Int]
+kaprekars base top =
+  nub . sort . concatMap kaps $
+  takeWhile (<= top * top `div` base ^ 2) $ (\x -> base ^ x - 1) <$> [1 ..]
+  where
+    kaps pb = filter (<= top) $ f <$> factors pb
+      where
+        f x
+          | x == pb = pb
+          | otherwise = x * inverse x (pb `div` x)
+
+main :: IO ()
+main = mapM_ print $ kaprekars 10 10000000