aparler/RosettaCodeData
1
0
Fork 0
Code Issues 12 Pull requests 3 Projects Releases Packages Wiki Activity Actions

Data commit

Browse source
This commit is contained in:
Ingy döt Net 2023-07-01 11:58:00 -04:00
parent 7387c8f97b
commit cb5bb5e222
199093 changed files with 3378972 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

16
Task/Hamming-numbers/Haskell/hamming-numbers-1.hs Normal file
View file

@ -0,0 +1,16 @@
hamming = 1 : map (2*) hamming `union` map (3*) hamming `union` map (5*) hamming
union a@(x:xs) b@(y:ys) = case compare x y of
LT -> x : union xs b
EQ -> x : union xs ys
GT -> y : union a ys
main = do
print $ take 20 hamming
print (hamming !! (1691-1), hamming !! (1692-1))
print $ hamming !! (1000000-1)
-- Output:
-- [1,2,3,4,5,6,8,9,10,12,15,16,18,20,24,25,27,30,32,36]
-- (2125764000,2147483648)
-- 519312780448388736089589843750000000000000000000000000000000000000000000000000000000

14
Task/Hamming-numbers/Haskell/hamming-numbers-2.hs Normal file
View file

@ -0,0 +1,14 @@
hammings :: () -> [Integer]
hammings() = 1 : foldr u [] [2,3,5] where
u n s = -- fix (merge s . map (n*) . (1:))
r where
r = merge s (map (n*) (1:r))
merge [] b = b
merge a@(x:xs) b@(y:ys) | x < y = x : merge xs b
| otherwise = y : merge a ys
main :: IO ()
main = do
print $ take 20 (hammings ())
print $ (hammings ()) !! 1690
print $ (hammings ()) !! (1000000-1)

2
Task/Hamming-numbers/Haskell/hamming-numbers-3.hs Normal file
View file

@ -0,0 +1,2 @@
hammFrom n = drop n $
iterate (\(_ , (a:t)) -> (a, union t [2*a,3*a,5*a])) (0, [1])

23
Task/Hamming-numbers/Haskell/hamming-numbers-4.hs Normal file
View file

@ -0,0 +1,23 @@
> take 20 $ map fst $ hammFrom 1
[1,2,3,4,5,6,8,9,10,12,15,16,18,20,24,25,27,30,32,36]
> take 2 $ map fst $ hammFrom 1691
[2125764000,2147483648]
> mapM_ print $ take 10 $ hammFrom 1
(1,[2,3,5])
(2,[3,4,5,6,10])
(3,[4,5,6,9,10,15])
(4,[5,6,8,9,10,12,15,20])
(5,[6,8,9,10,12,15,20,25])
(6,[8,9,10,12,15,18,20,25,30])
(8,[9,10,12,15,16,18,20,24,25,30,40])
(9,[10,12,15,16,18,20,24,25,27,30,40,45])
(10,[12,15,16,18,20,24,25,27,30,40,45,50])
(12,[15,16,18,20,24,25,27,30,36,40,45,50,60])
> map (length . snd . head . hammFrom) [2000,4000,8000,16000]
[402,638,1007,1596]
> map (logBase 2) $ zipWith (/) =<< tail $ [402,638,1007,1596]
[0.67,0.66,0.66]

10
Task/Hamming-numbers/Haskell/hamming-numbers-5.hs Normal file
View file

@ -0,0 +1,10 @@
hamm = foldr merge1 [] . iterate (map (5*)) .
foldr merge1 [] . iterate (map (3*))
$ iterate (2*) 1
where
merge1 (x:xs) ys = x : merge xs ys
{- 1, 2, 4, 8, 16, 32, ...
3, 6, 12, 24, 48, 96, ...
9, 18, 36, 72, 144, 288, ...
27, ... -}

35
Task/Hamming-numbers/Haskell/hamming-numbers-6.hs Normal file
View file

@ -0,0 +1,35 @@
-- directly find n-th Hamming number, in ~ O(n^{2/3}) time.
-- based on "top band" idea by Louis Klauder, from the DDJ discussion.
-- by Will Ness, original post: drdobbs.com/blogs/architecture-and-design/228700538
import Data.List (sortBy, foldl') -- '
import Data.Function (on)
main = let (r,t) = nthHam 1000000 in print t >> print (trival t)
trival (i,j,k) = 2^i * 3^j * 5^k
nthHam :: Int -> (Double, (Int, Int, Int)) -- ( 64bit: use Int!!! NB! )
nthHam n -- n: 1-based: 1,2,3...
| n <= 0 = error $ "n is 1--based: must be n > 0: " ++ show n
| n < 2 = ( 0.0, (0, 0, 0) ) -- trivial case so estimation works for rest
| w >= 1 = error $ "Breach of contract: (w < 1): " ++ show w
| m < 0 = error $ "Not enough triples generated: " ++ show ((c,n) :: (Int, Int))
| m >= nb = error $ "Generated band is too narrow: " ++ show (m,nb)
| otherwise = sortBy (flip compare `on` fst) b !! m -- m-th from top in sorted band
where
lb3 = logBase 2 3; lb5 = logBase 2 5; lb30_2 = logBase 2 30 / 2
v = (6*lb3*lb5* fromIntegral n)**(1/3) - lb30_2 -- estimated logval, base 2
estval n = (v + (1/v), 2/v) -- the space tweak! (thx, GBG!)
(hi,w) = estval n -- hi > logval > hi-w
m = fromIntegral (c - n) -- target index, from top
nb = length (b :: [(Double, (Int, Int, Int))]) -- length of the band
(c,b) = foldl_ (\(c,b) (i,t)-> let c2=c+i in c2 `seq` -- ( total count, the band )
case t of []-> (c2,b);[v]->(c2,v:b) ) (0,[]) -- ( =~= mconcat )
[ ( fromIntegral i+1, -- total triples w/ this (j,k)
[ (r,(i,j,k)) | frac < w ] ) -- store it, if inside band
| k <- [ 0 .. floor ( hi /lb5) ], let p = fromIntegral k*lb5,
j <- [ 0 .. floor ((hi-p)/lb3) ], let q = fromIntegral j*lb3 + p,
let (i,frac) = pr (hi-q) ; r = hi - frac -- r = i + q
] where pr = properFraction -- pr 1.24 => (1,0.24)
foldl_ = foldl'

40
Task/Hamming-numbers/Haskell/hamming-numbers-7.hs Normal file
View file

@ -0,0 +1,40 @@
{-# OPTIONS_GHC -O3 -XStrict #-}
import Data.Word
import Data.List (sortBy)
import Data.Function (on)
nthHam :: Word64 -> (Int, Int, Int)
nthHam n -- n: 1-based 1,2,3...
| n < 2 = case n of
0 -> error "nthHam: Argument is zero!"
_ -> (0, 0, 0) -- trivial case for 1
| m < 0 = error $ "Not enough triples generated: " ++ show (c,n)
| m >= nb = error $ "Generated band is too narrow: " ++ show (m,nb)
| otherwise = case res of (_, tv) -> tv -- 2^i * 3^j * 5^k
where
lb3 = logBase 2 3; lb5 = logBase 2 5.0
lbrt30 = logBase 2 $ sqrt 30 :: Double -- estimate adjustment as per WP
lg2est = (6 * lb3 * lb5 * fromIntegral n)**(1/3) - lbrt30 -- estimated logval, base 2
(hi,lo) = (lg2est + 1/lg2est, 2 * lg2est - hi) -- hi > log2est > lo
(c, b) = let klmt = floor (hi / lb5)
loopk k ck bndk =
if k > klmt then (ck, bndk) else
let p = hi - fromIntegral k * lb5; jlmt = floor (p / lb3)
loopj j cj bndj =
if j > jlmt then loopk (k + 1) cj bndj else
let q = p - fromIntegral j * lb3
(i, frac) = properFraction q
nj = j + 1; ncj = cj + fromIntegral i + 1
r = hi - frac
nbndj = i `seq` bndj `seq`
if r < lo then bndj
else case (r, (i, j, k)) of
nhd -> nhd `seq` nhd : bndj
in ncj `seq` nbndj `seq` loopj nj ncj nbndj
in loopj 0 ck bndk
in loopk 0 0 []
(m,nb) = ( fromIntegral $ c - n, length b ) -- m 0-based from top, |band|
(s,res) = ( sortBy (flip compare `on` fst) b, s!!m ) -- sorted decreasing, result<
main = putStrLn $ show $ nthHam 1000000000000

48
Task/Hamming-numbers/Haskell/hamming-numbers-8.hs Normal file
View file

@ -0,0 +1,48 @@
{-# OPTIONS_GHC -O3 -XStrict #-}
import Data.Word
import Data.List (sortBy)
import Data.Function (on)
nthHam :: Word64 -> (Int, Int, Int)
nthHam n -- n: 1-based 1,2,3...
| n < 2 = case n of
0 -> error "nthHam: Argument is zero!"
_ -> (0, 0, 0) -- trivial case for 1
| m < 0 = error $ "Not enough triples generated: " ++ show (c,n)
| m >= nb = error $ "Generated band is too narrow: " ++ show (m,nb)
| otherwise = case res of (_, tv) -> tv -- 2^i * 3^j * 5^k
where
lb3 = logBase 2 3; lb5 = logBase 2 5.0
lbrt30 = logBase 2 $ sqrt 30 :: Double -- estimate adjustment as per WP
lg2est = (6 * lb3 * lb5 * fromIntegral n)**(1/3) - lbrt30 -- estimated logval, base 2
(hi,lo) = (lg2est + 1/lg2est, 2 * lg2est - hi) -- hi > log2est > lo
bglb2 = 1267650600228229401496703205376 :: Integer
bglb3 = 2009178665378409109047848542368 :: Integer
bglb5 = 2943393543170754072109742145491 :: Integer
(c, b) = let klmt = floor (hi / lb5)
loopk k ck bndk =
if k > klmt then (ck, bndk) else
let p = hi - fromIntegral k * lb5; jlmt = floor (p / lb3)
loopj j cj bndj =
if j > jlmt then loopk (k + 1) cj bndj else
let q = p - fromIntegral j * lb3
(i, frac) = properFraction q
nj = j + 1; ncj = cj + fromIntegral i + 1
r = hi - frac
nbndj = i `seq` bndj `seq`
if r < lo then bndj
else
let bglg = bglb2 * fromIntegral i +
bglb3 * fromIntegral j +
bglb5 * fromIntegral k in
bglg `seq` case (bglg, (i, j, k)) of
nhd -> nhd `seq` nhd : bndj
in ncj `seq` nbndj `seq` loopj nj ncj nbndj
in loopj 0 ck bndk
in loopk 0 0 []
(m,nb) = ( fromIntegral $ c - n, length b ) -- m 0-based from top, |band|
-- (s,res) = (b, s!!m)
(s,res) = ( sortBy (flip compare `on` fst) b, s!!m ) -- sorted decreasing, result<
main = putStrLn $ show $ nthHam 1000000000000