93 lines
3.3 KiB
Haskell
93 lines
3.3 KiB
Haskell
{-# 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
|