Euler problems/141 to 150

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.Map((!),fromList,member)
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..]]
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
 
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
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
prim40=tail$take 40 primes
primeSqr=
    fromList[(a,fromList$zip b [1..])|
    a<-prim40,
    let b=nub[t|c<-[0..a-1],
    let t=mod (c*c) a]
    ]

isSqrt n
    |k= n==((^2).intSqrt) n
    |otherwise=False
    where
    k=foldl (&&) True [member  k ma |
        a<-prim40,
        let ma=(primeSqr !a),
        let k=mod n a
        ]
getOne a = [c|
    x<-factors t,
    a>x,
    let y=(a-x)*(3*a+x),
    let k=4*x,
    let (c,m)=divMod y k,
    m==0
    ]
    where
    t=(3*a^2)

getThree a = [[a,m,n]|
    m<-t,
    n<-[k|k<-t,mod k 5/=0],
    let z=(2*m+n)^2+3*n*n,
    isSqrt z
    ]
    where
    t=getOne a
gcdlst [x,y]=gcd x y
gcdlst (x:xs)=gcd x$gcdlst xs 
    
p143 k=[c|
    a<-[1+k*groups..groups*(k+1)],
    c<-getThree (a*5),
    gcdlst c==1
    ]
-- run test find test==[],so one of a b c is 5*x
test=[(a,b,c)|a<-t,b<-t,c<-t,
    f a b,
    f b c,
    f c a]
    where
    t=[1..4]
    f a b=elem (mod (a^2+b^2+a*b) 5) [0,1,4]

groups=200
 
google num
-- write file to change bignum to small num
  =if (num>33)
      then return()
      else do let k=p143 num
              appendFile "file.log" $(show$k)  ++"  "++(show num) ++"\n"
              appendFile "files.log" $(show$map sum k)  ++"  "++(show num) ++"\n"
              google (num+1)
-- first use main to make file.log
-- then run problem_143
main=google 0
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=((++[-1]).read) $head$split ' ' x
 
filer x
    |x<0=False
    |x>100000=False
    |otherwise=True
problem_143=do
    x<-readFile "files.log"
    let y=concat$map sToInt $lines x
    let z= filter filer y
    let t=[b|a<-z,b<-takeWhile (<=100000) [a*b|b<-[1..]]]
    print$ sum$nub t

Problem 144

Investigating multiple reflections of a laser beam.

Solution:

problem_144 = undefined

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
find2km :: Integral a => a -> (a,a)
find2km n = f 0 n
    where 
        f k m
            | r == 1 = (k,m)
            | otherwise = f (k+1) q
            where (q,r) = quotRem m 2        

millerRabinPrimality :: Integer -> Integer -> Bool
millerRabinPrimality n a
    | a <= 1 || a >= n-1 = 
        error $ "millerRabinPrimality: a out of range (" 
              ++ show a ++ " for "++ show n ++ ")" 
    | n < 2 = False
    | even n = False
    | b0 == 1 || b0 == n' = True
    | otherwise = iter (tail b)
    where
        n' = n-1
        (k,m) = find2km n'
        b0 = powMod n a m
        b = take (fromIntegral k) $ iterate (squareMod n) b0
        iter [] = False
        iter (x:xs)
            | x == 1 = False
            | x == n' = True
            | otherwise = iter xs

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
 
mulMod :: Integral a => a -> a -> a -> a
mulMod a b c = (b * c) `mod` a
squareMod :: Integral a => a -> a -> a
squareMod a b = (b * b) `rem` a
powMod :: Integral a => a -> a -> a -> a
powMod m = pow' (mulMod m) (squareMod m)
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:

problem_147 = undefined

Problem 148

Exploring Pascal's triangle.

Solution:

import List
digits n 
{-  123->[3,2,1]
 -   -}
     |n<7=[n]
     |otherwise= y:digits x 
     where
     (x,y)=divMod n 7

notDivX x=product$map (+1) $digits x

array::[Integer]
array=
    [a*b*c*d*e*f|
    let t=[1..7],
    a<-t,
    b<-t,
    c<-t,
    d<-t,
    e<-t,
    f<-t
    ]

fastNotDivX::Integer->Integer
fastNotDivX x=sum[k*a|a<-array]
    where
    k=product$map (+1) $digits x

sumNotDivX x=sum[notDivX a|a<-[0..x]]

-- sum[fastNotDivX x|x<-[0..b]]=sumNotDivX ((b+1)*7^6-1)
 
moreNotDivX =sum[notDivX a|a<-[1000000000.. 1000016499 ]]

google num
-- write file to change bignum to small num
  =if (num>8499)
      then return()
      else do appendFile "file.log" $(show$fastNotDivX num)  ++"  "++(show num) ++"\n"
              google (num+1)
-- first use main to make file.log
-- then run problem_148
main=google 0

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_148=do
    x<-readFile "file.log"
    let y=sum$map sToInt $lines x
    print (  y-(fromInteger moreNotDivX))

Problem 149

Searching for a maximum-sum subsequence.

Solution:

problem_149 = undefined

Problem 150

Searching a triangular array for a sub-triangle having minimum-sum.

Solution:

problem_150 = undefined