Difference between revisions of "Euler problems/121 to 130"
Line 153: | Line 153: | ||
Solution: |
Solution: |
||
<haskell> |
<haskell> |
||
+ | import Data.List |
||
⚫ | |||
+ | import Data.Map(fromList,(!)) |
||
+ | rad x= product[a|(a,_)<-fstfac x] |
||
+ | radMap=fromList[(a,fromList [(b,rad(a*1000+b))|b<-[0..999]])|a<-[0..100]] |
||
+ | fastrad x= |
||
+ | radMap!a!b |
||
+ | where |
||
+ | (a,b)=divMod x 1000 |
||
+ | maxSingFac x |
||
+ | |not$null ar=last ar |
||
+ | |otherwise=0 |
||
+ | where |
||
+ | ar=[a|(a,b)<-x,b==1] |
||
+ | testPrime x p divx= [swap(x,a,b)| |
||
+ | a<-[p2*a1|a1<-[1..n]], |
||
+ | gcd a x==1, |
||
+ | let b=x-a, |
||
+ | gcd b x==1, |
||
+ | gcd b a==1, |
||
+ | fastrad a*fastrad b<divx |
||
+ | ] |
||
+ | where |
||
+ | p2=p^2 |
||
+ | (n,m)=divMod x p2 |
||
+ | swap (a,b,c) |
||
+ | |b<c=[a,b] |
||
+ | |otherwise=[a,c] |
||
+ | test1 x divx |
||
+ | |fastrad (x-1)<divx=[[x,1]] |
||
+ | |otherwise=[] |
||
+ | test x |
||
+ | |(length ff>4)=[] |
||
+ | |(maxSingFac ff>1200)=[] |
||
+ | |otherwise= nub d |
||
+ | where |
||
+ | ra=fastrad x |
||
+ | ff=fstfac x |
||
+ | divx=div x ra |
||
+ | ba=div divx 2 |
||
+ | c1=takeWhile (<=ba) primes |
||
+ | d=test1 x divx++[b|p<-c1,b<-testPrime x p divx] |
||
+ | |||
+ | groups=1000 |
||
+ | p127 k=[m|a<-[1+k*groups..groups*(k+1)],let t=test a,not$null t,m<-t] |
||
+ | show1 x=foldl (++) "" $map ((++" \n").show2) x |
||
+ | show2 [a,b]=show a++" "++show b |
||
+ | google num |
||
+ | -- write file to change bignum to small num |
||
+ | =if (num>99) |
||
+ | then return() |
||
+ | else do appendFile "p127.log" $(show1$p127 num) |
||
+ | google (num+1) |
||
+ | main=google 0 |
||
+ | |||
+ | fstfac x = [(head a ,length a)|a<-group$primeFactors x] |
||
+ | primeFactors :: Integer -> [Integer] |
||
+ | primeFactors n = factor n primes |
||
+ | where |
||
+ | factor _ [] = [] |
||
+ | factor m (p:ps) | p*p > m = [m] |
||
+ | | m `mod` p == 0 = p : factor (m `div` p) (p:ps) |
||
+ | | otherwise = factor m ps |
||
+ | merge xs@(x:xt) ys@(y:yt) = case compare x y of |
||
+ | LT -> x : (merge xt ys) |
||
+ | EQ -> x : (merge xt yt) |
||
+ | GT -> y : (merge xs yt) |
||
+ | |||
+ | diff xs@(x:xt) ys@(y:yt) = case compare x y of |
||
+ | LT -> x : (diff xt ys) |
||
+ | EQ -> diff xt yt |
||
+ | GT -> diff xs yt |
||
+ | |||
+ | primes, nonprimes :: [Integer] |
||
+ | primes = [2,3,5] ++ (diff [7,9..] nonprimes) |
||
+ | nonprimes = foldr1 f . map g $ tail primes |
||
+ | where f (x:xt) ys = x : (merge xt ys) |
||
+ | g p = [ n*p | n <- [p,p+2..]] |
||
+ | split :: Char -> String -> [String] |
||
+ | split = unfoldr . split' |
||
+ | |||
+ | split' :: Char -> String -> Maybe (String, String) |
||
+ | split' c l |
||
+ | | null l = Nothing |
||
+ | | otherwise = Just (h, drop 1 t) |
||
+ | where (h, t) = span (/=c) l |
||
+ | |||
+ | sToInt x=((+0).read) $head$split ' ' x |
||
+ | |||
⚫ | |||
+ | x<-readFile "p127.log" |
||
+ | let y=sum$map sToInt $lines x |
||
+ | print (y-1-100000) |
||
</haskell> |
</haskell> |
||
Revision as of 12:55, 27 December 2007
Problem 121
Investigate the game of chance involving coloured discs.
Solution:
problem_121 = undefined
Problem 122
Finding the most efficient exponentiation method.
Solution using a depth first search, pretty fast :
import Data.List
import Data.Array.Diff
import Control.Monad
depthAddChain 12 branch mins = mins
depthAddChain d branch mins = foldl' step mins $ nub $ filter (> head branch)
$ liftM2 (+) branch branch
where
step da e | e > 200 = da
| otherwise =
case compare (da ! e) d of
GT -> depthAddChain (d+1) (e:branch) $ da // [(e,d)]
EQ -> depthAddChain (d+1) (e:branch) da
LT -> da
baseBranch = [2,1]
baseMins :: DiffUArray Int Int
baseMins = listArray (1,200) $ 0:1: repeat maxBound
problem_122 = sum . elems $ depthAddChain 2 baseBranch baseMins
Problem 123
Determining the remainder when (pn − 1)n + (pn + 1)n is divided by pn2.
Solution:
primes = 2 : filter ((==1) . length . primeFactors) [3,5..]
primeFactors n = factor n primes
where
factor _ [] = []
factor m (p:ps) | p*p > m = [m]
| m `mod` p == 0 = p : [m `div` p]
| otherwise = factor m ps
isPrime :: Integer -> Bool
isPrime 1 = False
isPrime n = case (primeFactors n) of
(_:_:_) -> False
_ -> True
problem_123 =
head[a+1|a<-[20000,20002..22000],
let n=2*(a+1)*primes!!(fromInteger a),
n>10^10
]
Problem 124
Determining the kth element of the sorted radical function.
Solution:
import List
primes :: [Integer]
primes = 2 : filter ((==1) . length . primeFactors) [3,5..]
primeFactors :: Integer -> [Integer]
primeFactors n = factor n primes
where
factor _ [] = []
factor m (p:ps) | p*p > m = [m]
| m `mod` p == 0 = p : factor (m `div` p) (p:ps)
| otherwise = factor m ps
problem_124=snd$(!!9999)$sort[(product$nub$primeFactors x,x)|x<-[1..100000]]
Problem 125
Finding square sums that are palindromic.
Solution:
import Data.List
import Data.Map(fromList,(!))
toFloat = (flip encodeFloat 0)
digits n
{- 123->[3,2,1]
-}
|n<10=[n]
|otherwise= y:digits x
where
(x,y)=divMod n 10
palind n=foldl dmm 0 (digits n)
-- 123 ->321
dmm=(\x y->x*10+y)
makepalind n=(n*d+p):[c+b*d|b<-[0..9]]
where
a=(+1)$floor$logBase 10$fromInteger n
d=10^a
p=palind n
c=n*10*d+p
twomakep n=(n*d+p)
where
a=(+1)$floor$logBase 10$fromInteger n
d=10^a
p=palind n
p125=sum[b|a<-[1..999], b<-makepalind a,not$null$ funa b]
p125a=sum[b|a<-[1000..9999], let b=twomakep a,not$null$ funa b]
p125b=sum[a|a<-[1..9], not$null$ funa a]
findmap=fromList[(a,2*fill_map a)|a<-[0..737]]
fill_map x
|odd x=fastsum $div (x-1) 2
|otherwise=fastsumodd (x-1)
where
fastsum y=div (y*(y+1)*(2*y+1)) 6
fastsumodd y=let n=div (y+1) 2 in div (n*(4*n*n-1)) 3
funa x=[(a,x)|a<-takeWhile (\a->a*a*a<4*x) [2..],funb a x]
funb x n
|odd x=d2==0 && 4*d1>=(x+1)^2 && isSq d1
|otherwise=d4==0 && odd d3 && d3>=(x+1)^2 && isSq d3
where
x1=fromInteger x
(d1,d2)=divMod ((n-findmap! x1)) (x)
(d3,d4)=divMod ((4*n-findmap!x1)) (x)
isSq x=(floor$sqrt$toFloat x)^2==x
problem_125 = (p125+p125a+p125b)
Problem 126
Exploring the number of cubes required to cover every visible face on a cuboid.
Solution:
problem_126 = undefined
Problem 127
Investigating the number of abc-hits below a given limit.
Solution:
import Data.List
import Data.Map(fromList,(!))
rad x= product[a|(a,_)<-fstfac x]
radMap=fromList[(a,fromList [(b,rad(a*1000+b))|b<-[0..999]])|a<-[0..100]]
fastrad x=
radMap!a!b
where
(a,b)=divMod x 1000
maxSingFac x
|not$null ar=last ar
|otherwise=0
where
ar=[a|(a,b)<-x,b==1]
testPrime x p divx= [swap(x,a,b)|
a<-[p2*a1|a1<-[1..n]],
gcd a x==1,
let b=x-a,
gcd b x==1,
gcd b a==1,
fastrad a*fastrad b<divx
]
where
p2=p^2
(n,m)=divMod x p2
swap (a,b,c)
|b<c=[a,b]
|otherwise=[a,c]
test1 x divx
|fastrad (x-1)<divx=[[x,1]]
|otherwise=[]
test x
|(length ff>4)=[]
|(maxSingFac ff>1200)=[]
|otherwise= nub d
where
ra=fastrad x
ff=fstfac x
divx=div x ra
ba=div divx 2
c1=takeWhile (<=ba) primes
d=test1 x divx++[b|p<-c1,b<-testPrime x p divx]
groups=1000
p127 k=[m|a<-[1+k*groups..groups*(k+1)],let t=test a,not$null t,m<-t]
show1 x=foldl (++) "" $map ((++" \n").show2) x
show2 [a,b]=show a++" "++show b
google num
-- write file to change bignum to small num
=if (num>99)
then return()
else do appendFile "p127.log" $(show1$p127 num)
google (num+1)
main=google 0
fstfac x = [(head a ,length a)|a<-group$primeFactors x]
primeFactors :: Integer -> [Integer]
primeFactors n = factor n primes
where
factor _ [] = []
factor m (p:ps) | p*p > m = [m]
| m `mod` p == 0 = p : factor (m `div` p) (p:ps)
| otherwise = factor m ps
merge xs@(x:xt) ys@(y:yt) = case compare x y of
LT -> x : (merge xt ys)
EQ -> x : (merge xt yt)
GT -> y : (merge xs yt)
diff xs@(x:xt) ys@(y:yt) = case compare x y of
LT -> x : (diff xt ys)
EQ -> diff xt yt
GT -> diff xs yt
primes, nonprimes :: [Integer]
primes = [2,3,5] ++ (diff [7,9..] nonprimes)
nonprimes = foldr1 f . map g $ tail primes
where f (x:xt) ys = x : (merge xt ys)
g p = [ n*p | n <- [p,p+2..]]
split :: Char -> String -> [String]
split = unfoldr . split'
split' :: Char -> String -> Maybe (String, String)
split' c l
| null l = Nothing
| otherwise = Just (h, drop 1 t)
where (h, t) = span (/=c) l
sToInt x=((+0).read) $head$split ' ' x
problem_127=do
x<-readFile "p127.log"
let y=sum$map sToInt $lines x
print (y-1-100000)
Problem 128
Which tiles in the hexagonal arrangement have prime differences with neighbours?
Solution:
problem_128 = undefined
Problem 129
Investigating minimal repunits that divide by n.
Solution:
problem_129 = undefined
Problem 130
Finding composite values, n, for which n−1 is divisible by the length of the smallest repunits that divide it.
Solution:
import Data.List
mulMod :: Integral a => a -> a -> a -> a
mulMod a b c= (b * c) `rem` a
squareMod :: Integral a => a -> a -> a
squareMod a b = (b * b) `rem` a
pow' :: (Num a, Integral b) => (a -> a -> a) -> (a -> a) -> a -> b -> a
pow' _ _ _ 0 = 1
pow' mul sq x' n' = f x' n' 1
where
f x n y
| n == 1 = x `mul` y
| r == 0 = f x2 q y
| otherwise = f x2 q (x `mul` y)
where
(q,r) = quotRem n 2
x2 = sq x
powMod :: Integral a => a -> a -> a -> a
powMod m = pow' (mulMod m) (squareMod m)
primeFactors :: Integer -> [Integer]
primeFactors n = factor n primes
where
factor _ [] = []
factor m (p:ps) | p*p > m = [m]
| m `mod` p == 0 = p : factor (m `div` p) (p:ps)
| otherwise = factor m ps
primes=2:[a|a<-[2..],isPrime a]
isPrime :: Integer -> Bool
isPrime 1 = False
isPrime n = case (primeFactors n) of
(_:_:_) -> False
_ -> True
fstfac x = [(head a ,length a)|a<-group$primeFactors x]
fac [(x,y)]=[x^a|a<-[0..y]]
fac (x:xs)=[a*b|a<-fac [x],b<-fac xs]
factors x=fac$fstfac x
fun x |(not$null a)=head a
|otherwise=0
where
a=take 1 [n|n<-sort$factors (x-1),(powMod x 10 n)==1]
problem_130 =sum$take 25[a|a<-[1..],
not$isPrime a,
let b=fun a,
b/=0,
mod (a-1) b==0,
mod a 3 /=0]