Euler problems/181 to 190

fun a1 b1 = sum [ e | e <- [2..a*b-1],
                      gcd e (a*b) == 1,
                      gcd (e-1) a == 2,
                      gcd (e-1) b == 2 ]
  where a = a1-1
        b = b1-1
 
problem_182 = fun 1009 3643

-- Does the decimal expansion of p/q terminate?
terminating p q = 1 == reduce [2,5] (q `div` gcd p q)
        where reduce   []   n = n
              reduce (x:xs) n | n `mod` x == 0 = reduce (x:xs) (n `div` x)
                              | otherwise      = reduce xs n
 
-- The expression (round $ fromIntegral n / e) computes the integer k
-- for which (n/k)^k is at a maximum. Also note that, given a rational number
-- r and a natural number k, the decimal expansion of r^k terminates if
-- and only if the decimal expansion of r does.
answer = sum [if terminating n (round $ fromIntegral n / e) then -n else n
                | n <- [5 .. 10^4]]
        where e = exp 1
 
main = print answer

import Data.List
import Control.Monad
import Data.Char
import System.Random
 
type Mind = [([Char],Int)]
 
values :: [Char]
values = "0123456789"
 
 
score :: [Char] -> [Char] -> Int
score guess answer = foldr (\(a,b) y -> if a == b then y+1 else y) 0 
      (zip guess answer)
 
scores :: Mind -> [Char] -> [Int]
scores m g = map (\x -> abs ((snd x) - score (fst x) g)) m
 
scoreMind :: Mind -> [Char] -> Int
scoreMind m g = sum $ scores m g
 
 
ex1 :: Mind
ex1 = 
  [("90342",2),
   ("39458",2),
   ("51545",2),
   ("34109",1),
   ("12531",1),
   ("70794",0)]
 
ex2 :: Mind   
ex2 = 
  [
   ("5616185650518293",2),
   ("3847439647293047",1),
   ("5855462940810587",3),
   ("9742855507068353",3),
   ("4296849643607543",3),
   ("3174248439465858",1),
   ("4513559094146117",2),
   ("7890971548908067",3),
   ("8157356344118483",1),
   ("2615250744386899",2),
   ("8690095851526254",3),
   ("6375711915077050",1),
   ("6913859173121360",1),
   ("6442889055042768",2),
   ("2321386104303845",0),
   ("2326509471271448",2),
   ("5251583379644322",2),
   ("1748270476758276",3),
   ("4895722652190306",1),
   ("3041631117224635",3),
   ("1841236454324589",3),
   ("2659862637316867",2)]
 
 
guesses :: [Char] -> Int -> [[Char]]
guesses str pos = [ left ++ n:(tail right) | n<-values]
  where (left,right) = splitAt pos str
 
bestGuess :: Mind -> [[Char]] -> [Int]
bestGuess mind guesses = bestGuesses
  where scores = map (scoreMind mind) guesses
        bestScore = minimum scores
        bestGuesses = elemIndices bestScore scores
 
iterateGuesses :: Mind -> [Char] -> [Char]
iterateGuesses mind value = nextguess value mins
   where allguesses = map (guesses value) [0..(length value)-1]
         mins = map (bestGuess mind) allguesses
 
nextguess :: [Char] -> [[Int]] -> [Char]
nextguess = zipWith choose
  where choose x [y] = intToDigit y
        choose x _   = x
 
 
iterateMind :: Mind -> [Char] -> [([Char], Int)]
iterateMind mind n = zip b c
  where a = drop 2 $ inits $ iterate (iterateGuesses mind) n
        b = last $ takeWhile (\x -> (last x) `notElem` (init x)) a
        c = map (scoreMind mind) b
 
 
randomStart :: Int -> IO [Char]
randomStart n = replicateM n (getStdRandom (randomR ('0','9')))
 
main :: IO ()
main = do
  let ex = ex1
  x <- randomStart (length (fst (head ex)))
  let y = iterateMind ex x
      done = snd (last y) == 0
  if done then (putStrLn $ (fst.last) y)
          else main

import Control.Monad
import Data.List
import qualified Data.Set as S
 
ensure p x = guard (p x) >> return x
selectDistinct 0 _  = [[]]
selectDistinct n [] = []
selectDistinct n (x:xs) = map (x:) (selectDistinct (n - 1) xs) ++ selectDistinct n xs
 
data Environment a = Environment { guesses      :: [(Int, [a])]
                                 , restrictions :: [S.Set a]
                                 , assignmentsLeft :: Int
                                 } deriving (Eq, Ord, Show)
 
reorder e = e { guesses = sort . guesses $ e }
domain  = S.fromList "0123456789"
initial = Environment gs (replicate a S.empty) a where
    a   = length . snd . head $ gs
    gs  = [(2, "5616185650518293"), (1, "3847439647293047"), (3, "5855462940810587"), (3, "9742855507068353"), (3, "4296849643607543"), (1, "3174248439465858"), (2, "4513559094146117"), (3, "7890971548908067"), (1, "8157356344118483"), (2, "2615250744386899"), (3, "8690095851526254"), (1, "6375711915077050"), (1, "6913859173121360"), (2, "6442889055042768"), (0, "2321386104303845"), (2, "2326509471271448"), (2, "5251583379644322"), (3, "1748270476758276"), (1, "4895722652190306"), (3, "3041631117224635"), (3, "1841236454324589"), (2, "2659862637316867")]
 
acceptableCounts e = small >= 0 && big <= assignmentsLeft e where
    ns    = (0:) . map fst . guesses $ e
    small = minimum ns
    big   = maximum ns
 
positions s = map fst . filter (not . snd) . zip [0..] . zipWith S.member s
acceptableRestriction  r (n, s) = length (positions s r) >= n
acceptableRestrictions e = all (acceptableRestriction (restrictions e)) (guesses e)
 
firstGuess = head . guesses
sanityCheck e = acceptableRestrictions e && acceptableCounts e
 
solve e@(Environment _  _ 0) = [[]]
solve e@(Environment [] r _) = mapM (S.toList . (domain S.\\)) r
solve e' = do
    is   <- m
    newE <- f is
    rest <- solve newE
    return $ interleaveAscIndices is (l is) rest
        where
    f = ensure sanityCheck . update e
    m = selectDistinct n (positions g (restrictions e)) 
    e = reorder e'
    l = fst . flip splitAscIndices g
    (n, g) = firstGuess e
 
splitAscIndices = indices 0 where
    indices _ [] xs = ([], xs)
    indices n (i:is) (x:xs)
        | i == n = let (b, e) = indices (n + 1) is     xs in (x:b, e)
        | True   = let (b, e) = indices (n + 1) (i:is) xs in (b, x:e)
 
interleaveAscIndices = indices 0 where
    indices _ [] [] ys = ys
    indices n (i:is) (x:xs) ys
        | i == n = x : indices (n + 1) is xs ys
        | True   = head ys : indices (n + 1) (i:is) (x:xs) (tail ys)
 
update (Environment ((_, a):gs) r l) is = Environment newGs restriction (l - length is) where
    (assignment, newRestriction)    = splitAscIndices is a
    (_, oldRestriction)             = splitAscIndices is r
    restriction                     = zipWith S.insert newRestriction oldRestriction
    newGs                           = map updateEntry gs
    updateEntry (n', a')            = (newN, newA) where
        (dropped, newA) = splitAscIndices is a'
        newN            = n' - length (filter id $ zipWith (==) assignment dropped)
 
problem_185 = head . solve $ initial

module PI (prime,primes,pI) where 
import Control.Monad.ST
import System.IO.Unsafe
import qualified Data.Map as M
import Data.ByteString.Char8 (readFile,lines,readInt) 
import Data.Maybe
import Data.Array.ST
import Data.Array.IArray
 
r = runSTUArray 
            (do a <- newArray (0,3001134) 0 :: ST s (STUArray s Int Int)
                writeArray a 0 1
                zipWithM_ (writeArray a) [0..] primes
                return a) 
 
{-# NOINLINE s #-}
s = M.fromDistinctAscList $ map (\(x,y) -> (y,x)) (assocs r)
 
prime n = r!n
 
pI :: Int -> Int
pI n = 
    case M.splitLookup n s of
       (_,Just x,_) -> (x+1)
       (_,_,b) -> snd (head (M.assocs b))
 
{-# NOINLINE primes #-}
primes :: [Int]
primes = unsafePerformIO $ do
  l <- Data.ByteString.Char8.readFile "primes_to_5M.txt"
  let p = Data.ByteString.Char8.lines l
      r = map (fst . fromJust . readInt) p::[Int]
  return r  
 
 
import PI
import Data.List
 
s n k =       ( n `div` (prime (k-1))) - k + 1
 
semiPrimeCount n =
  let last = pI $ floor $ sqrt (fromIntegral n)
      s k = pI ( n `div` (prime (k-1))) - k + 1
      pI2 = foldl' (\x y -> s y + x) 0 [1..last]
  in pI2
 
main = print (semiPrimeCount 100000000)

fastPower x 1 modulus = x `mod` modulus
fastPower x n modulus
  | even n = fastPower ((x*x) `mod` modulus) (n `div` 2) modulus
  | otherwise = (x * (fastPower x (n-1) modulus)) `mod` modulus
 
modulus = 10^8
phi = 40000000 -- eulerTotient of 10^8
 
a :: Int ->  Int  -> Int
a n 1 = n
-- a n k = n^(a n (k-1))
a n k = fastPower n (a n (k-1) `mod` phi) modulus
 
problem_188 = a 1777 1855

f l = product $ zipWith (^) l [1..]
 
fmin n = floor $ f [ i*2/(n+1) | i<-[1..n]]
 
problem_190 = sum $ map fmin [2..15]