Euler problems/141 to 150
Jump to navigation
Jump to search
The printable version is no longer supported and may have rendering errors. Please update your browser bookmarks and please use the default browser print function instead.
Problem 141
Investigating progressive numbers, n, which are also square.
Solution:
import Data.List
intSqrt :: Integral a => a -> a
intSqrt n
| n < 0 = error "intSqrt: negative n"
| otherwise = f n
where
f x = if y < x then f y else x
where y = (x + (n `quot` x)) `quot` 2
isSqrt n = n==((^2).intSqrt) n
takec a b =
two++takeWhile (<=e12)
[sq| c1<-[1..], let c=c1*c1,let sq=(c^2*a^3*b+b^2*c) ]
where
e12=10^12
two=[sq|c<-[b,2*b],let sq=(c^2*a^3*b+b^2*c) ]
problem_141=
sum$nub[c|
(a,b)<-takeWhile (\(a,b)->a^3*b+b^2<e12)
[(a,b)|
a<-[2..e4],
b<-[1..(a-1)]
],
gcd a b==1,
c<-takec a b,
isSqrt c
]
where
e4=120
e12=10^12
Problem 142
Perfect Square Collection
Solution:
import List
isSquare n = (round . sqrt $ fromIntegral n) ^ 2 == n
aToX (a,b,c)=[x,y,z]
where
x=div (a+b) 2
y=div (a-b) 2
z=c-x
{-
- 2 2 2
- a = c + d
- 2 2 2
- a = e + f
- 2 2 2
- c = e + b
- let b=x*y then
- (y + xb)
- c= ---------
- 2
- (-y + xb)
- e= ---------
- 2
- (-x + yb)
- d= ---------
- 2
- (x + yb)
- f= ---------
- 2
-
- and
- 2 2 2
- a = c + d
- then
- 2 2 2 2
- 2 (y + x ) (x y + 1)
- a = ---------------------
- 4
-
-}
problem_142 = sum$head[aToX(t,t2 ,t3)|
a<-[3,5..50],
b<-[(a+2),(a+4)..50],
let a2=a^2,
let b2=b^2,
let n=(a2+b2)*(a2*b2+1),
isSquare n,
let t=div n 4,
let t2=a2*b2,
let t3=div (a2*(b2+1)^2) 4
]
Problem 143
Investigating the Torricelli point of a triangle
Solution:
import Data.List
import Data.Array.ST
import Data.Array
import qualified Data.Array.Unboxed as U
import Control.Monad
mkCan :: [Int] -> [(Int,Int)]
mkCan lst = map func $ group $ insert 3 lst
where
func ps@(p:_)
| p == 3 = (3,2*l-1)
| otherwise = (p, 2*l)
where
l = length ps
spfArray :: U.UArray Int Int
spfArray
= runSTUArray
(do ar <- newArray (2,13397) 0
let loop k
| k > 13397 = return ()
| otherwise = do writeArray ar k 2
loop (k+2)
loop 2
let go i
| i > 13397 = return ar
| otherwise
= do p <- readArray ar i
if (p == 0)
then do writeArray ar i i
let run k
| k > 13397 = go (i+2)
| otherwise
= do q <- readArray ar k
when (q == 0)
(writeArray ar k i)
run (k+2*i)
run (i*i)
else go (i+2)
go 3)
factArray :: Array Int [Int]
factArray
= runSTArray
(do ar <- newArray (1,13397) []
let go i
| i > 13397 = return ar
| otherwise = do let p = spfArray U.! i
q = i `div` p
fs <- readArray ar q
writeArray ar i (p:fs)
go (i+1)
go 2)
sdivs :: Int -> [(Int,Int)]
sdivs s
= filter ((<= 100000) . uncurry (+)) $ zip sds' lds'
where
bd = 3*s*s
pks = mkCan $ factArray ! s
fun (p,k) = take (k+1) $ iterate (*p) 1
ds = map fun pks
(sds,lds) = span ((< bd) . (^2)) . sort $ foldr (liftM2 (*)) [1] ds
sds' = map (+ 2*s) sds
lds' = reverse $ map (+ 2*s) lds
pairArray :: Array Int [Int]
pairArray
= runSTArray
(do ar <- newArray (3,50000) []
let go s
| s > 13397 = return ar
| otherwise
= do let run [] = go (s+1)
run ((r,q):ds)
= do lst <- readArray ar r
let nlst = insert q lst
writeArray ar r nlst
run ds
run $ sdivs s
go 1)
select2 :: [Int] -> [(Int,Int)]
select2 [] = []
select2 (a:bs) = [(a,b) | b <- bs] ++ select2 bs
sumArray :: U.UArray Int Bool
sumArray
= runSTUArray
(do ar <- newArray (12,100000) False
let go r
| r > 33332 = return ar
| otherwise
= do let run [] = go (r+1)
run ((q,p):xs)
= do when (p `elem` (pairArray!q))
(writeArray ar (p+q+r) True)
run xs
run $ filter ((<= 100000) . (+r) . uncurry (+)) $
select2 $ pairArray!r
go 3)
main :: IO ()
main = writeFile "p143.log"$show$ sum [s | (s,True) <- U.assocs sumArray]
problem_143 = main
Problem 144
Investigating multiple reflections of a laser beam.
Solution:
type Point = (Double, Double)
type Vector = (Double, Double)
type Normal = (Double, Double)
sub :: Vector -> Vector -> Vector
sub (x,y) (a,b) = (x-a, y-b)
mull :: Double -> Vector -> Vector
mull s (x,y) = (s*x, s*y)
mulr :: Vector -> Double -> Vector
mulr v s = mull s v
dot :: Vector -> Vector -> Double
dot (x,y) (a,b) = x*a + y*b
normSq :: Vector -> Double
normSq v = dot v v
normalize :: Vector -> Vector
normalize v
|len /= 0 =mulr v (1.0/len)
|otherwise=error "Vettore nullo.\n"
where
len = (sqrt . normSq) v
proj :: Vector -> Vector -> Vector
proj a b = mull ((dot a b)/normSq b) b
reflect :: Vector -> Normal -> Vector
reflect i n = sub i $ mulr (proj i n) 2.0
type Ray = (Point, Vector)
makeRay :: Point -> Vector -> Ray
makeRay p v = (p, v)
getPoint :: Ray -> Double -> Point
getPoint ((px,py),(vx,vy)) t = (px + t*vx, py + t*vy)
type Ellipse = (Double, Double)
getNormal :: Ellipse -> Point -> Normal
getNormal (a,b) (x,y) = ((-b/a)*x, (-a/b)*y)
rayFromPoint :: Ellipse -> Vector -> Point -> Ray
rayFromPoint e v p = makeRay p (reflect v (getNormal e p))
test :: Point -> Bool
test (x,y) = y > 0 && x >= -0.01 && x <= 0.01
intersect :: Ellipse -> Ray -> Point
intersect (e@(a,b)) (r@((px,py),(vx,vy))) =
getPoint r t1
where
c0 = normSq (vx/a, vy/b)
c1 = 2.0 * dot (vx/a, vy/b) (px/a, py/b)
c2 = (normSq (px/a, py/b)) - 1.0
(t0, t1) = quadratic c0 c1 c2
quadratic :: Double -> Double -> Double -> (Double, Double)
quadratic a b c
|d < 0= error "Discriminante minore di zero"
|otherwise= if (t0 < t1) then (t0, t1) else (t1, t0)
where
d = b * b - 4.0 * a * c
sqrtD = sqrt d
q = if b < 0 then -0.5*(b - sqrtD) else 0.5*(b + sqrtD)
t0 = q / a
t1 = c / q
calculate :: Ellipse -> Ray -> Int -> IO ()
calculate e (r@(o,d)) n
|test p=print n
|otherwise=do
putStrLn $ "\rHit " ++ show n
calculate e (rayFromPoint e d p) (n+1)
where
p = intersect e r
origin = (0.0,10.1)
direction = sub (1.4,-9.6) origin
ellipse = (5.0,10.0)
problem_144 = do
calculate ellipse (makeRay origin direction) 0
Problem 145
How many reversible numbers are there below one-billion?
Solution:
import List
digits n
{- 123->[3,2,1]
-}
|n<10=[n]
|otherwise= y:digits x
where
(x,y)=divMod n 10
-- 123 ->321
dmm=(\x y->x*10+y)
palind n=foldl dmm 0 (digits n)
isOdd x=(length$takeWhile odd x)==(length x)
isOdig x=isOdd m && s<=h
where
k=x+palind x
m=digits k
y=floor$logBase 10 $fromInteger x
ten=10^y
s=mod x 10
h=div x ten
a2=[i|i<-[10..99],isOdig i]
aa2=[i|i<-[10..99],isOdig i,mod i 10/=0]
a3=[i|i<-[100..999],isOdig i]
m5=[i|i1<-[0..99],i2<-[0..99],
let i3=i1*1000+3*100+i2,
let i=10^6* 8+i3*10+5,
isOdig i
]
fun i
|i==2 =2*le aa2
|even i=(fun 2)*d^(m-1)
|i==3 =2*le a3
|i==7 =fun 3*le m5
|otherwise=0
where
le=length
m=div i 2
d=2*le a2
problem_145 = sum[fun a|a<-[1..9]]
Problem 146
Investigating a Prime Pattern
Solution:
import List
isPrime x=millerRabinPrimality x 2
--isPrime x=foldl (&& )True [millerRabinPrimality x y|y<-[2,3,7,61,24251]]
six=[1,3,7,9,13,27]
allPrime x=foldl (&&) True [isPrime k|a<-six,let k=x^2+a]
linkPrime [x]=filterPrime x
linkPrime (x:xs)=[y|
a<-linkPrime xs,
b<-[0..(x-1)],
let y=b*prxs+a,
let c=mod y x,
elem c d]
where
prxs=product xs
d=filterPrime x
filterPrime p=
[a|
a<-[0..(p-1)],
length[b|b<-six,mod (a^2+b) p/=0]==6
]
testPrimes=[2,3,5,7,11,13,17,23]
primes=[2,3,5,7,11,13,17,23,29]
test =
sum[y|
y<-linkPrime testPrimes,
y<1000000,
allPrime (y)
]==1242490
p146 =[y|y<-linkPrime primes,y<150000000,allPrime (y)]
problem_146=[a|a<-p146, allNext a]
allNext x=
sum [1|(x,y)<-zip a b,x==y]==6
where
a=[x^2+b|b<-six]
b=head a:(map nextPrime a)
nextPrime x=head [a|a<-[(x+1)..],isPrime a]
main=writeFile "p146.log" $show $sum problem_146
Problem 147
Rectangles in cross-hatched grids
Solution:
numPar w h
= h*(h+1)*w*(w+1) `div` 4
numDiag w h
| w < h = numDiag h w
| otherwise =
w*diff - h*(diff+1) `div` 2
where
diff = (2*h-1)*h*(2*h+1) `div` 3
problem_147 =
sum [2*(numPar w h + numDiag w h) |
w <- [2 .. 43], h <- [1 .. w-1]]
+ sum [numPar w w + numDiag w w |
w <- [1 .. 43]]
+ sum [numPar w h + numDiag w h |
w <- [44 .. 47],
h <- [1 .. 43]]
Problem 148
Exploring Pascal's triangle.
Solution:
triangel 0 = 0
triangel n
|n <7 =n+triangel (n-1)
|n==k7 =28^k
|otherwise=(triangel i) + j*(triangel (n-i))
where
i=k7*((n-1)`div`k7)
j= -(n`div`(-k7))
k7=7^k
k=floor(log (fromIntegral n)/log 7)
problem_148=triangel (10^9)
Problem 149
Searching for a maximum-sum subsequence.
Solution:
#include<stdio.h>
#define N 2000
#define max(a,b) ((a) > (b) ? (a) : (b))
int s[4000001];
int MaxSubsequenceSum(int s[] , int n) {
int j;
int ThisSum, MaxSum ;
ThisSum = MaxSum = 0;
for ( j=0; j<n ; j++)
{
ThisSum += s[j];
if (ThisSum> MaxSum)
MaxSum = ThisSum;
else if (ThisSum < 0)
ThisSum = 0;
}
return MaxSum;
}
long long Generate(int ind){
long long k = ind;
if (ind <= 55)
return ((100003 - 200003*k + 300007*k*k*k) % 1000000) - 500000;
return (s[k-24]+s[k-55]+1000000)%1000000-500000;
}
int main()
{
int sums=0;
int maxx=0;
for (int i=1;i<4000001;i++){
s[i]=(int)(Generate(i));
}
printf("%d %d \n",s[10],s[100]);
int ks[N],kss[N];
for (int k=0;k<N;k++){
for(int b=0;b<N;b++)
{
ks[b]=s[k*N+b+1];
kss[b]=s[b*N+k+1];
}
sums=MaxSubsequenceSum(ks,N);
sums=max(sums,MaxSubsequenceSum(kss,N));
maxx=max (maxx,sums);
}
int ksi,ksj, x,y,y1;
for (int k=-N+1;k<N;k++){
ksi=ksj=0;
for(int b=0;b<N;b++)
{
x=k+b;
y=b;
y1=N-1-b;
if (x>-1 && x<N && y>-1 && y<N)
ks[ksi++]=s[x*N+y+1];
if (x>-1 && x<N && y1>-1 && y1<N)
kss[ksj++]=s[x*N+y1+1];
}
sums=MaxSubsequenceSum(ks,ksi);
sums=max(sums,MaxSubsequenceSum(kss,ksj));
maxx=max (maxx,sums);
}
printf("%d\n",maxx);
}
problem_149 = main
Problem 150
Searching a triangular array for a sub-triangle having minimum-sum.
Solution:
problem_150 = undefined