Data commit

Task/Humble-numbers/Haskell/humble-numbers-1.hs

@@ -0,0 +1,27 @@
+import Data.Set (deleteFindMin, fromList, union)
+import Data.List.Split (chunksOf)
+import Data.List (group)
+import Data.Bool (bool)
+
+--------------------- HUMBLE NUMBERS ----------------------
+humbles :: [Integer]
+humbles = go $ fromList [1]
+  where
+    go sofar = x : go (union pruned $ fromList ((x *) <$> [2, 3, 5, 7]))
+      where
+        (x, pruned) = deleteFindMin sofar
+
+-- humbles = filter (all (< 8) . primeFactors) [1 ..]
+-------------------------- TEST ---------------------------
+main :: IO ()
+main = do
+  putStrLn "First 50 Humble numbers:"
+  mapM_ (putStrLn . concat) $
+    chunksOf 10 $ justifyRight 4 ' ' . show <$> take 50 humbles
+  putStrLn "\nCount of humble numbers for each digit length 1-25:"
+  mapM_ print $
+    take 25 $ ((,) . head <*> length) <$> group (length . show <$> humbles)
+
+------------------------- DISPLAY -------------------------
+justifyRight :: Int -> a -> [a] -> [a]
+justifyRight n c = (drop . length) <*> (replicate n c ++)

Task/Humble-numbers/Haskell/humble-numbers-2.hs

@@ -0,0 +1,93 @@
+{-# OPTIONS_GHC -O2 #-}
+
+import Data.Word (Word16)
+import Data.Bits (shiftR, (.&.))
+import Data.Function (fix)
+import Data.List (group, intercalate)
+import Data.Time.Clock.POSIX (getPOSIXTime)
+
+--------------------- HUMBLE NUMBERS ----------------------
+data LogRep = LogRep {-# UNPACK #-} !Double
+                     {-# UNPACK #-} !Word16
+                     {-# UNPACK #-} !Word16
+                     {-# UNPACK #-} !Word16
+                     {-# UNPACK #-} !Word16 deriving Show
+instance Eq LogRep where
+  (==) (LogRep la _ _ _ _) (LogRep lb _ _ _ _) = la == lb
+instance Ord LogRep where
+  (<=) (LogRep la _ _ _ _) (LogRep lb _ _ _ _) = la <= lb
+logrep2Integer :: LogRep -> Integer
+logrep2Integer (LogRep _ w x y z) = xpnd 2 w $ xpnd 3 x $ xpnd 5 y $ xpnd 7 z 1 where
+  xpnd m v = go v m where
+    go i mlt acc =
+      if i <= 0 then acc else
+      go (i `shiftR` 1) (mlt * mlt) (if i .&. 1 == 0 then acc else acc * mlt)
+cOneLR :: LogRep
+cOneLR = LogRep 0.0 0 0 0 0
+cLgOf2 :: Double
+cLgOf2 = logBase 10 2
+cLgOf3 :: Double
+cLgOf3 = logBase 10 3
+cLgOf5 :: Double
+cLgOf5 = logBase 10 5
+cLgOf7 :: Double
+cLgOf7 = logBase 10 7
+cLgOf10 :: Double
+cLgOf10 = cLgOf2 + cLgOf5
+mulLR2 :: LogRep -> LogRep
+mulLR2 (LogRep lg w x y z) = LogRep (lg + cLgOf2) (w + 1) x y z
+mulLR3 :: LogRep -> LogRep
+mulLR3 (LogRep lg w x y z) = LogRep (lg + cLgOf3) w (x + 1) y z
+mulLR5 :: LogRep -> LogRep
+mulLR5 (LogRep lg w x y z) = LogRep (lg + cLgOf5) w x (y + 1) z
+mulLR7 :: LogRep -> LogRep
+mulLR7 (LogRep lg w x y z) = LogRep (lg + cLgOf7) w x y (z + 1)
+
+humbleLRs :: () -> [LogRep]
+humbleLRs() = cOneLR : foldr u [] [mulLR2, mulLR3, mulLR5, mulLR7] where
+  u nmf s = fix (merge s . map nmf . (cOneLR:)) where
+    merge a [] = a
+    merge [] b = b
+    merge a@(x:xs) b@(y:ys) | x < y     = x : merge xs b
+                            | otherwise = y : merge a ys
+
+-------------------------- TEST ---------------------------
+main :: IO ()
+main = do
+  putStrLn "First 50 Humble numbers:"
+  mapM_ (putStrLn . concat) $
+    chunksOf 10 $ justifyRight 4 ' ' . show <$> take 50 (map logrep2Integer $ humbleLRs())
+  strt <- getPOSIXTime
+  putStrLn "\nCount of humble numbers for each digit length 1-255:"
+  putStrLn "Digits       Count              Accum"
+  mapM_ putStrLn $ take 255 $ groupFormat $ humbleLRs()
+  stop <- getPOSIXTime
+  putStrLn $ "Counting took " ++ show (1.0 * (stop - strt)) ++ " seconds."
+
+------------------------- DISPLAY -------------------------
+chunksOf :: Int -> [a] -> [[a]]
+chunksOf n = go where
+  go [] = []
+  go ilst = take n ilst : go (drop n ilst)
+
+justifyRight :: Int -> a -> [a] -> [a]
+justifyRight n c = (drop . length) <*> (replicate n c ++)
+
+commaString :: String -> String
+commaString =
+  let grpsOf3 [] = []
+      grpsOf3 is = let (frst, rest) = splitAt 3 is in frst : grpsOf3 rest
+  in reverse . intercalate "," . grpsOf3 . reverse
+
+groupFormat :: [LogRep] -> [String]
+groupFormat = go (0 :: Int) (0 :: Int) 0 where
+  go _ _ _ [] = []
+  go i cnt cacc ((LogRep lg _ _ _ _) : lrtl) =
+    let nxt = truncate (lg / cLgOf10) :: Int in
+    if nxt == i then go i (cnt + 1) cacc lrtl else
+    let ni = i + 1
+        ncacc = cacc + cnt
+        str = justifyRight 4 ' ' (show ni) ++
+                justifyRight 14 ' ' (commaString $ show cnt) ++
+                justifyRight 19 ' ' (commaString $ show ncacc)
+    in str : go ni 1 ncacc lrtl

Task/Humble-numbers/Haskell/humble-numbers-3.hs

@@ -0,0 +1,95 @@
+{-# OPTIONS_GHC -O2 #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+import Data.Word (Word64)
+import Data.Bits (shiftR)
+import Data.Function (fix)
+import Data.Array.Unboxed (UArray, elems)
+import Data.Array.Base (MArray(newArray, unsafeRead, unsafeWrite))
+import Data.Array.IO (IOUArray)
+import Data.List (intercalate)
+import Data.Time.Clock.POSIX (getPOSIXTime)
+import Data.Array.Unsafe (unsafeFreeze)
+
+cNumDigits :: Int
+cNumDigits = 877
+
+cShift :: Int
+cShift = 50
+cFactor :: Word64
+cFactor = 2^cShift
+cLogOf10 :: Word64
+cLogOf10 = cFactor
+cLogOf7 :: Word64
+cLogOf7 = round $ (logBase 10 7 :: Double) * fromIntegral cFactor
+cLogOf5 :: Word64
+cLogOf5 = round $ (logBase 10 5 :: Double) * fromIntegral cFactor
+cLogOf3 :: Word64
+cLogOf3 = round $ (logBase 10 3 :: Double) * fromIntegral cFactor
+cLogOf2 :: Word64
+cLogOf2 = cLogOf10 - cLogOf5
+cLogLmt :: Word64
+cLogLmt = fromIntegral cNumDigits * cLogOf10
+
+humbles :: () -> [Integer]
+humbles() = 1 : foldr u [] [2,3,5,7] where
+  u n s = fix (merge s . map (n*) . (1:)) where
+    merge a [] = a
+    merge [] b = b
+    merge a@(x:xs) b@(y:ys) | x < y     = x : merge xs b
+                            | otherwise = y : merge a ys
+
+-------------------------- TEST ---------------------------
+main :: IO ()
+main = do
+  putStrLn "First 50 humble numbers:"
+  mapM_ (putStrLn . concat) $
+    chunksOf 10 $ justifyRight 4 ' ' . show <$> take 50 (humbles())
+  putStrLn $ "\nCount of humble numbers for each digit length 1-"
+                  ++ show cNumDigits ++ ":"
+  putStrLn "Digits       Count              Accum"
+  strt <- getPOSIXTime
+  mbins <- newArray (0, cNumDigits - 1) 0 :: IO (IOUArray Int Int)
+  let loopw w =
+        if w >= cLogLmt then return () else
+        let loopx x =
+              if x >= cLogLmt then loopw (w + cLogOf2) else
+              let loopy y =
+                    if y >= cLogLmt then loopx (x + cLogOf3) else
+                    let loopz z =
+                          if z >= cLogLmt then loopy (y + cLogOf5) else do
+                            let ndx = fromIntegral (z `shiftR` cShift)
+                            v <- unsafeRead mbins ndx
+                            unsafeWrite mbins ndx (v + 1)
+                            loopz (z + cLogOf7) in loopz y in loopy x in loopx w
+  loopw 0
+  stop <- getPOSIXTime
+  bins <- unsafeFreeze mbins :: IO (UArray Int Int)
+  mapM_ putStrLn $ format $ elems bins
+  putStrLn $ "Counting took " ++ show (realToFrac (stop - strt)) ++ " seconds."
+
+------------------------- DISPLAY -------------------------
+chunksOf :: Int -> [a] -> [[a]]
+chunksOf n = go where
+  go [] = []
+  go ilst = take n ilst : go (drop n ilst)
+
+justifyRight :: Int -> a -> [a] -> [a]
+justifyRight n c = (drop . length) <*> (replicate n c ++)
+
+commaString :: String -> String
+commaString =
+  let grpsOf3 [] = []
+      grpsOf3 s = let (frst, rest) = splitAt 3 s in frst : grpsOf3 rest
+  in reverse . intercalate "," . grpsOf3 . reverse
+
+format :: [Int] -> [String]
+format = go (0 :: Int) 0 where
+  go _ _ [] = []
+  go i cacc (hd : tl) =
+    let ni = i + 1
+        ncacc = cacc + hd
+        str = justifyRight 4 ' ' (show ni) ++
+                justifyRight 14 ' ' (commaString $ show hd) ++
+                justifyRight 19 ' ' (commaString $ show ncacc)
+    in str : go ni ncacc tl