https://wiki.haskell.org/api.php?action=feedcontributions&user=Scvalex&feedformat=atomHaskellWiki - User contributions [en]2024-03-28T10:34:57ZUser contributionsMediaWiki 1.35.5https://wiki.haskell.org/index.php?title=Euler_problems/81_to_90&diff=21908Euler problems/81 to 902008-07-23T15:15:58Z<p>Scvalex: replaced solution to problem 87 with one that takes 0.4s (old one took 13.2s) and uses about 7mb of memory (old one used 184mb) and doesn't spend about 60% of its time in gc</p>
<hr />
<div>== [http://projecteuler.net/index.php?section=problems&id=81 Problem 81] ==<br />
Find the minimal path sum from the top left to the bottom right by moving right and down.<br />
<br />
Solution:<br />
<haskell><br />
import Data.List (unfoldr)<br />
<br />
columns s = <br />
unfoldr f s<br />
where<br />
f [] = Nothing<br />
f xs = Just $ (\(a,b) -> (read a, drop 1 b)) $ break (==',') xs<br />
<br />
firstLine ls = scanl1 (+) ls<br />
<br />
nextLine pl [] = pl<br />
nextLine pl (n:nl) = <br />
nextLine p' nl<br />
where<br />
p' = nextCell (head pl) pl n<br />
nextCell _ [] [] = []<br />
nextCell pc (p:pl) (n:nl) = <br />
pc' : nextCell pc' pl nl<br />
where pc' = n + min p pc<br />
<br />
minSum (p:nl) = <br />
last $ nextLine p' nl<br />
where<br />
p' = firstLine p<br />
<br />
problem_81 c = minSum $ map columns $ lines c<br />
main=do<br />
f<-readFile "matrix.txt"<br />
print$problem_81 f<br />
</haskell><br />
<br />
Another solution that uses Data.Array:<br />
<haskell><br />
import Data.Array<br />
<br />
problem_81 :: String -> Integer<br />
problem_81 txt = b ! (0, 0)<br />
where<br />
a = listArray ((0,0), (79,79)) . concatMap read . map (\xs -> '[' : xs ++ "]") . lines $ txt<br />
b = array ((0,0), (80,80)) $ [((80, i), 0) | i <- [0..80]]<br />
++ [((i, 80), 0) | i <- [0..80]]<br />
++ [((79, i), a ! (79, i) + b ! (79, i+1)) | i <- [79,78..0]]<br />
++ [((i, 79), a ! (i, 79) + b ! (i+1, 79)) | i <- [79,78..0]]<br />
++ [((i, j), a ! (i,j) + min (b ! (i+1, j)) (b ! (i, j+1))) | i <- [78,77..0], j <- [78,77..0]]<br />
<br />
main :: IO ()<br />
main = do<br />
txt <- readFile "matrix.txt"<br />
print $ problem_81 txt<br />
</haskell><br />
<br />
I am offering this solution not because it is particularly<br />
brilliant, but because it introduces the wonderful fgl Graph<br />
Library written by Martin Erwig. Martin's Data.Graph.Inductive<br />
library allows you to solve problems 81,82, and 83 with exactly<br />
the same code, and best of all, little or no thinking. The idea<br />
is to convert the n by n matrix into an n^2 by n^2 graph whose<br />
edges depend on the allowed paths. Fortunately these graphs are<br />
very sparse, averaging only 4 edges per node. This allows us to<br />
use the Dijkstra algorithm to find the shortest path in a graph.<br />
<br />
The only slightly dodgy bit is problem 82, where we must find<br />
the shortest path from the first column to the last column. In<br />
order to avoid recomputing the Dijkstra algorithm over and over<br />
again, you have to be a little careful in the order of<br />
evaluation. I used spTree function from<br />
Data.Graph.Inductive.Query.SP which generated the shortest path<br />
tree from a given initial node to all other nodes. I then map<br />
over this tree with the nodes of the graph that are in the last<br />
column. The tree only needs to be calculated once for each<br />
element in the first column, rather than for every pair (i,j).<br />
This reduces the running time by a factor of n.<br />
Henry Laxen -- Apr. 27, 2008<br />
<br />
<haskell><br />
import Data.Graph.Inductive<br />
import Data.Graph.Inductive.Graph<br />
import Data.Graph.Inductive.Query.SP<br />
import Data.Graph.Inductive.Internal.RootPath<br />
import Data.List (unfoldr)<br />
<br />
type Matrix = [[Int]]<br />
type IJ = (Int, Int)<br />
<br />
connect81, connect82, connect83 :: [IJ]<br />
connect81 = [(1,0),(0,1)]<br />
connect82 = [(-1,0),(1,0),(0,1)]<br />
connect83 = [(-1,0),(0,-1),(1,0),(0,1)]<br />
<br />
dimensions :: Matrix -> IJ<br />
dimensions matrix = (length matrix, length (matrix!!0))<br />
<br />
ijToindex :: Matrix -> IJ -> Int<br />
ijToindex matrix (i,j) = i*rows + j<br />
where (rows,cols) = dimensions matrix<br />
<br />
indexToij :: Matrix -> Int -> IJ<br />
indexToij matrix index = divMod index rows<br />
where (rows,cols) = dimensions matrix<br />
<br />
ijValid :: Matrix -> [IJ] -> [IJ]<br />
ijValid matrix ijs = filter f ijs<br />
where (rows,cols) = dimensions matrix<br />
f (i,j) = i >= 0 && i < rows && j >= 0 && j < cols<br />
<br />
ijPlus :: IJ -> IJ -> IJ<br />
ijPlus (i1,j1) (i2,j2) = ((i1+i2),(j1+j2)) <br />
<br />
mEdges :: Matrix -> [IJ] -> IJ -> [(Int, Int, Int)]<br />
mEdges matrix connectL (i,j) =<br />
let ijs = ijValid matrix $ map (ijPlus (i,j)) connectL<br />
in map (\(x,y) -> (ijToindex matrix (i,j), <br />
ijToindex matrix (x,y),<br />
matrix!!x!!y)) ijs<br />
<br />
mGraph :: Matrix -> [IJ] -> Gr IJ Int<br />
mGraph matrix connectL =<br />
let (rows,cols) = dimensions matrix<br />
ijs = [(i,j) | i<-[0..(rows-1)], j<-[0..(cols-1)]]<br />
mnodes = map (\(x,y) -> (ijToindex matrix (x,y) ,(x,y))) ijs<br />
medges = concatMap (mEdges matrix connectL) ijs<br />
-- Everything written above is leading up to this line,<br />
-- namely transforming an m x n matrix into an mn x mn graph <br />
in mkGraph mnodes medges<br />
<br />
<br />
mSPlen :: Matrix -> [IJ] -> [IJ] -> [IJ] -> ((IJ, IJ), Int)<br />
mSPlen matrix connectL from to =<br />
let (rows,cols) = dimensions matrix<br />
mx (i,j) = matrix!!i!!j<br />
ijI = ijToindex matrix<br />
gr = mGraph matrix connectL<br />
spTrees = map (\x -> (x,spTree (ijI x) gr)) from<br />
distance (i,j) = getDistance (ijI (i,j)) <br />
distances = concatMap (\x -> map (\y -> ((fst x,y),<br />
(distance y (snd x)) + mx (fst x))) to) spTrees<br />
in foldl1 (\x y -> if snd x < snd y then x else y) distances<br />
<br />
debug = False <br />
mName = if debug then "small_matrix.txt" else "matrix.txt"<br />
<br />
columns :: [Char] -> [Int]<br />
columns s = <br />
unfoldr f s<br />
where<br />
f [] = Nothing<br />
f xs = Just $ (\(a,b) -> (read a, drop 1 b)) $ break (==',') xs<br />
<br />
main = do<br />
f<-readFile mName<br />
let matrix = map columns $ lines f<br />
(rows,cols) = dimensions matrix<br />
firstColumn = [(i,0) | i<-[0..(rows-1)]]<br />
lastColumn = [(i,(rows-1)) | i<-[0..(rows-1)]]<br />
topLeft = [(0,0)]<br />
bottomRight = [(rows-1,cols-1)]<br />
putStrLn $ "Problem 81: " ++ <br />
(show $ mSPlen matrix connect81 topLeft bottomRight)<br />
putStrLn $ "Problem 82: " ++ <br />
(show $ mSPlen matrix connect82 firstColumn lastColumn)<br />
putStrLn $ "Problem 83: " ++ <br />
(show $ mSPlen matrix connect83 topLeft bottomRight)<br />
<br />
<br />
</haskell><br />
<br />
<br />
<br />
== [http://projecteuler.net/index.php?section=problems&id=82 Problem 82] ==<br />
Find the minimal path sum from the left column to the right column.<br />
<br />
Solution:<br />
<haskell><br />
import Data.List<br />
import qualified Data.Map as M<br />
import Data.Array<br />
<br />
minPathSum xs t= <br />
stepPath M.empty $ M.singleton t $ arr ! t<br />
where <br />
len = genericLength $ head xs<br />
ys = concat $ transpose xs<br />
arr = listArray ((1, 1), (len, len)) ys<br />
nil = ((0,0),0)<br />
stepPath ds as <br />
|fs2 p1==len =snd p1 <br />
|fs2 p2==len =snd p2 <br />
|fs2 p3==len =snd p3 <br />
|otherwise=stepPath ds' as3<br />
where<br />
fs2=fst.fst<br />
((i, j), cost) = <br />
minimumBy (\(_,a) (_,b) -> compare a b) $ M.assocs as<br />
tas = M.delete (i,j) as<br />
(p1, as1) = if i == len then (nil, tas) else check (i+1, j) tas<br />
(p2, as2) = if j == len then (nil, as1) else check (i, j+1) as1<br />
(p3, as3) = if j == 1 then (nil, as2) else check (i, j-1) as2<br />
check pos zs =<br />
if pos `M.member` tas || pos `M.member` ds <br />
then (nil, zs)<br />
else (entry, uncurry M.insert entry $ zs)<br />
where<br />
entry = (pos, cost + arr ! pos) <br />
ds' = M.insert (i, j) cost ds<br />
<br />
main=do<br />
let parse = map (read . ("["++) . (++"]")) . words<br />
a<-readFile "matrix.txt"<br />
let s=parse a<br />
let m=minimum[p|a<-[1..80],let p=minPathSum s (1,a)]<br />
appendFile "p82.log"$show m<br />
<br />
problem_82 = main<br />
</haskell><br />
<br />
== [http://projecteuler.net/index.php?section=problems&id=83 Problem 83] ==<br />
Find the minimal path sum from the top left to the bottom right by moving left, right, up, and down.<br />
<br />
Solution:<br />
<br />
A very verbose solution based on the Dijkstra algorithm. Infinity could be represented by any large value instead of the data type Distance. Also, some equality and ordering tests are not really correct. To be semantically correct, I think infinity == infinity should not be True and infinity > infinity should fail. But for this script's purpose it works like this.<br />
<br />
<haskell><br />
import Array (Array, listArray, bounds, inRange, assocs, (!))<br />
import qualified Data.Map as M <br />
(fromList, Map, foldWithKey, <br />
lookup, null, delete, insert, empty, update)<br />
import Data.List (unfoldr)<br />
import Control.Monad.State (State, execState, get, put)<br />
import Data.Maybe (fromJust, fromMaybe)<br />
<br />
type Weight = Integer<br />
<br />
data Distance = D Weight | Infinity<br />
deriving (Show)<br />
<br />
instance Eq Distance where<br />
(==) Infinity Infinity = True<br />
(==) (D a) (D b) = a == b<br />
(==) _ _ = False<br />
<br />
instance Ord Distance where<br />
compare Infinity Infinity = EQ<br />
compare Infinity (D _) = GT<br />
compare (D _) Infinity = LT<br />
compare (D a) (D b) = compare a b<br />
<br />
data (Eq n, Num w) => Arc n w = A {node :: n, weight :: w}<br />
deriving (Show)<br />
<br />
type Index = (Int, Int)<br />
type NodeMap = M.Map Index Distance<br />
type Matrix = Array Index Weight<br />
type Path = Arc Index Weight<br />
type PathMap = M.Map Index [Path]<br />
<br />
data Queues = Q {input :: NodeMap, output :: NodeMap, pathMap :: PathMap}<br />
deriving (Show)<br />
<br />
listToMatrix :: [[Weight]] -> Matrix<br />
listToMatrix xs = listArray ((1,1),(cols,rows)) $ concat $ xs<br />
where<br />
cols = length $ head xs<br />
rows = length xs<br />
<br />
directions :: [Index]<br />
directions = [(0,-1), (0,1), (-1,0), (1,0)]<br />
<br />
add :: (Num a) => (a, a) -> (a, a) -> (a, a)<br />
add (a,b) (a', b') = (a+a',b+b')<br />
<br />
arcs :: Matrix -> Index -> [Path]<br />
arcs a idx = do<br />
d <- directions<br />
let n = add idx d<br />
if (inRange (bounds a) n) then<br />
return $ A n (a ! n)<br />
else<br />
fail "out of bounds"<br />
<br />
paths :: Matrix -> PathMap<br />
paths a = M.fromList $ map (\(idx,_) -> (idx, arcs a idx)) $ assocs a<br />
<br />
nodes :: Matrix -> NodeMap<br />
nodes a = <br />
M.fromList $ (\((i,_):xs) -> (i, D (a ! (1,1))):xs) $ <br />
map (\(idx,_) -> (idx, Infinity)) $ assocs a<br />
<br />
extractMin :: NodeMap -> (NodeMap, (Index, Distance))<br />
extractMin m = (M.delete (fst minNode) m, minNode)<br />
where<br />
minNode = M.foldWithKey mini ((0,0), Infinity) m<br />
mini i' v' (i,v)<br />
| v' < v = (i', v')<br />
| otherwise = (i,v)<br />
<br />
dijkstra :: State Queues ()<br />
dijkstra = do<br />
Q i o am <- get<br />
let (i', n) = extractMin i<br />
let o' = M.insert (fst n) (snd n) o<br />
let i'' = updateNodes n am i'<br />
put $ Q i'' o' am<br />
if M.null i'' then return () else dijkstra<br />
<br />
updateNodes :: (Index, Distance) -> PathMap -> NodeMap -> NodeMap<br />
updateNodes (i, D d) am nm = foldr f nm ds<br />
where<br />
ds = fromJust $ M.lookup i am<br />
f :: Path -> NodeMap -> NodeMap<br />
f (A i' w) m = fromMaybe m val<br />
where<br />
val = do<br />
v <- M.lookup i' m<br />
if (D $ d+w) < v then<br />
return $ M.update (const $ Just $ D (d+w)) i' m<br />
else return m<br />
<br />
shortestPaths :: Matrix -> NodeMap<br />
shortestPaths xs = output $ dijkstra `execState` (Q n M.empty a)<br />
where<br />
n = nodes xs<br />
a = paths xs<br />
<br />
problem_83 :: [[Weight]] -> Weight<br />
problem_83 xs = jd $ M.lookup idx $ shortestPaths matrix<br />
where<br />
matrix = listToMatrix xs<br />
idx = snd $ bounds matrix<br />
jd (Just (D d)) = d<br />
main=do<br />
f<-readFile "matrix.txt"<br />
let m=map sToInt $lines f<br />
print $problem_83 m<br />
split :: Char -> String -> [String]<br />
split = unfoldr . split'<br />
<br />
split' :: Char -> String -> Maybe (String, String)<br />
split' c l<br />
| null l = Nothing<br />
| otherwise = Just (h, drop 1 t)<br />
where (h, t) = span (/=c) l<br />
sToInt x=map ((+0).read) $split ',' x<br />
</haskell><br />
<br />
== [http://projecteuler.net/index.php?section=problems&id=84 Problem 84] ==<br />
In the game, Monopoly, find the three most popular squares when using two 4-sided dice.<br />
<br />
This may not be the shortest or the fastest implementation, but<br />
I hope it is one of the clearest. I have one comment about the<br />
experience of solving this problem that I would like to share<br />
with you. At first I thought I would have to make use of the<br />
Control.Monad.State library, but being relatively new to<br />
Haskell, I quickly found myself in the slough of type checker<br />
despond. It was then that I remembered that foldl/foldr can<br />
used instead of "State," and now I found myself in the celestial<br />
city of type checker heaven, with Haskell preventing me from<br />
making silly mistakes at every turn. HenryLaxen May 7, 2008<br />
<br />
<haskell><br />
import Data.Array.IArray<br />
import Data.List<br />
import Data.Ord<br />
import System.Random<br />
<br />
<br />
data Squares = <br />
GO | A1 | CC1 | A2 | T1 | R1 | B1 | CH1 | B2 | B3 | JAIL | <br />
C1 | U1 | C2 | C3 | R2 | D1 | CC2 | D2 | D3 | FP | <br />
E1 | CH2 | E2 | E3 | R3 | F1 | F2 | U2 | F3 | G2J | <br />
G1 | G2 | CC3 | G3 | R4 | CH3 | H1 | T2 | H2 <br />
deriving (Eq,Ord,Enum,Read,Show,Ix)<br />
<br />
type Roll = [Int]<br />
<br />
data Cards = GoTo Squares | R | U | Back3 | Other<br />
deriving (Eq,Ord,Read,Show)<br />
<br />
type Deck = [Cards]<br />
<br />
data GameState = GameState<br />
{ position :: Squares,<br />
doublesCount :: Int,<br />
chance :: [Cards],<br />
communityChest :: [Cards],<br />
history :: [Squares]<br />
} deriving (Eq,Ord,Read,Show)<br />
<br />
deckCommunityChest = [ GoTo JAIL, GoTo GO ] ++ replicate 14 Other<br />
deckChance = [ GoTo GO, GoTo JAIL, GoTo C1, <br />
GoTo E3, GoTo H2, GoTo R1] ++<br />
[ R, U, Back3] ++<br />
replicate 6 Other<br />
<br />
doubles :: Roll -> Bool<br />
doubles r = r!!0 == r!!1<br />
<br />
defaultGameState = GameState<br />
{ position = GO,<br />
doublesCount = 0,<br />
chance = deckChance,<br />
communityChest = deckCommunityChest,<br />
history = [GO]<br />
}<br />
<br />
takeCard :: Deck -> (Cards,Deck)<br />
takeCard cards = (card,deck)<br />
where card = head cards<br />
deck = tail cards ++ [card]<br />
<br />
nextR g = case position g of<br />
CH1 -> R2<br />
CH2 -> R3<br />
CH3 -> R1<br />
<br />
nextU g = case position g of <br />
CH1 -> U1<br />
CH2 -> U2<br />
CH3 -> U1<br />
<br />
doCommunityChest :: GameState -> GameState<br />
doCommunityChest g =<br />
let (card,deck) = takeCard (communityChest g)<br />
rotate g = g {communityChest = deck }<br />
cases = case card of<br />
GoTo sq -> g { position = sq }<br />
Other -> g <br />
in rotate cases<br />
<br />
doChance :: GameState -> GameState<br />
doChance g =<br />
let (card,deck) = takeCard (chance g)<br />
rotate g = g {chance = deck }<br />
cases = case card of<br />
GoTo sq -> g { position = sq}<br />
R -> g { position = nextR g }<br />
U -> g { position = nextU g }<br />
-- you might back up from CH3 to CC3 so checkForCards again<br />
Back3 -> checkForCards (g { position = position (newPosition g (-3))})<br />
Other -> g <br />
in rotate cases<br />
<br />
newPosition :: GameState -> Int -> GameState<br />
newPosition g n = g {position = toEnum $ <br />
(fromEnum (position g) + n) `mod` (fromEnum H2 + 1)}<br />
<br />
checkForCards :: GameState -> GameState<br />
checkForCards g <br />
| (position g) `elem` [CH1, CH2, CH3] = doChance g<br />
| (position g) `elem` [CC1, CC2, CC3] = doCommunityChest g<br />
| otherwise = g<br />
<br />
travel :: GameState -> [Int] -> GameState<br />
travel g roll = <br />
let value = sum roll<br />
checkDoubles <br />
| doubles roll && doublesCount g == 2 = <br />
g { position = JAIL,<br />
doublesCount = 0 }<br />
| doubles roll = move $ g { doublesCount = (doublesCount g) + 1}<br />
| otherwise = move $ g { doublesCount = 0}<br />
move g = newPosition g value<br />
checkForJail g<br />
| (position g) == G2J = g { position = JAIL }<br />
| otherwise = g<br />
saveHistory g = g { history = (position g) : (history g) }<br />
in saveHistory $ checkForCards $ checkForJail $ checkDoubles <br />
<br />
<br />
game :: GameState -> [Roll] -> GameState<br />
-- As an exercise in what a difference strictness can make<br />
-- compare the performance of this with replacing foldl' by foldl<br />
game g rolls = foldl' (\x y -> travel x y) g rolls<br />
<br />
statistics :: [Squares] -> [(Squares, Float)]<br />
statistics history = <br />
let a = accumArray (+) 0 (GO,H2) (zip history (repeat 1)) :: Array Squares Int<br />
b = assocs a<br />
c = reverse $ sortBy (comparing snd) b<br />
(sq,cnt) = unzip c -- wiki formatting bug, should be unzip c<br />
total = sum cnt<br />
stats = map (\x -> ((fromIntegral x) / (fromIntegral total) * 100)) cnt<br />
in take 3 $ zip sq stats<br />
<br />
<br />
r = [[1,1],[2,2],[2,2],[4,4]]<br />
t = game defaultGameState r -- useful for debugging<br />
<br />
pairs :: [a] -> [[a]]<br />
pairs [] = [[]]<br />
pairs (x:y:xs) = [[x,y]] ++ (pairs xs)<br />
<br />
<br />
dieSides :: (Int,Int)<br />
-- dieSides = (1,6)<br />
dieSides = (1,4)<br />
maxRolls = 100000<br />
<br />
main = do<br />
seed <- newStdGen<br />
let rolls = pairs (randomRs dieSides seed)<br />
stats = statistics (history (game defaultGameState <br />
(take maxRolls rolls)))<br />
result = map (\x -> fromEnum (fst x)) stats<br />
print (stats,result)<br />
<br />
</haskell><br />
== [http://projecteuler.net/index.php?section=problems&id=85 Problem 85] ==<br />
Investigating the number of rectangles in a rectangular grid.<br />
<br />
Solution:<br />
<haskell><br />
import List<br />
problem_85 = snd$head$sort <br />
[(k,a*b)|<br />
a<-[1..100],<br />
b<-[1..100],<br />
let k=abs (a*(a+1)*(b+1)*b-8000000)<br />
]<br />
</haskell><br />
<br />
== [http://projecteuler.net/index.php?section=problems&id=86 Problem 86] ==<br />
Exploring the shortest path from one corner of a cuboid to another.<br />
<br />
Solution:<br />
<haskell><br />
import Data.List<br />
isSquare x = <br />
(truncate $ sqrt $ fromIntegral x)^2 == x<br />
<br />
cube m = <br />
sum [ (a`div`2) - if a > m then (a - m -1) else 0|<br />
a <- [1..2*m],<br />
isSquare ((a)^2 + m2)<br />
]<br />
where<br />
m2 = m * m<br />
<br />
problem_86 =<br />
findIndex (>1000000) (scanl (+) 0 (map cube [1..]))<br />
</haskell><br />
<br />
== [http://projecteuler.net/index.php?section=problems&id=87 Problem 87] ==<br />
Investigating numbers that can be expressed as the sum of a prime square, cube, and fourth power?<br />
<br />
Solution:<br />
<haskell><br />
import Data.Array.Unboxed<br />
<br />
takeMapPrimes :: Integer -> (Integer -> Integer) -> [Integer]<br />
takeMapPrimes u f = takeWhile (<u) . map f $ primes<br />
<br />
squares = takeMapPrimes 50000000 (^2)<br />
cubes = takeMapPrimes 50000000 (^3)<br />
fourths = takeMapPrimes 50000000 (^4)<br />
<br />
expressible :: UArray Integer Bool<br />
expressible = accumArray (||) False (1, 50000000) [(t, True) | a <- squares,<br />
b <- takeWhile (<(50000000-a)) cubes,<br />
c <- takeWhile (<(50000000-a-b)) fourths,<br />
let t = a + b + c]<br />
<br />
problem_87 :: Int<br />
problem_87 = length $ filter id $ elems expressible<br />
</haskell><br />
<br />
== [http://projecteuler.net/index.php?section=problems&id=88 Problem 88] ==<br />
Exploring minimal product-sum numbers for sets of different sizes.<br />
<br />
Solution:<br />
<haskell><br />
import Data.List<br />
import qualified Data.Set as S<br />
import qualified Data.Map as M<br />
<br />
primes = 2 : filter ((==1) . length . primeFactors) [3,5..] <br />
primeFactors n = factors n primes<br />
where factors n (p:ps) | p*p > n = [n]<br />
| n `mod` p == 0 = p : factors (n `div` p) (p:ps)<br />
| otherwise = factors n ps<br />
isPrime n | n > 1 = (==1) . length . primeFactors $ n<br />
| otherwise = False<br />
<br />
facts = concat . takeWhile valid . iterate facts' . (:[])<br />
where valid xs = length (head xs) > 1<br />
facts' = nub' . concatMap factsnext<br />
nub' = S.toList . S.fromList<br />
factsnext xs = <br />
let factsnext' [] = []<br />
factsnext' (y:ys) = map (form y) ys ++ factsnext' ys<br />
form a b = a*b : (delete b . delete a $ xs)<br />
in map sort . factsnext' $ xs <br />
<br />
problem_88 = sum' . extract . scanl addks M.empty . filter (not . isPrime) $ [2..]<br />
where extract = head . dropWhile (\nm -> M.size nm < 11999)<br />
sum' = S.fold (+) 0 . S.fromList . M.elems<br />
addks nm n = foldl (addk n) nm . facts . primeFactors $ n<br />
addk n nm ps =<br />
let k = length ps + n - sum ps<br />
kGood = k > 1 && k < 12001 && k `M.notMember` nm<br />
in if kGood then M.insert k n nm else nm<br />
</haskell><br />
<br />
== [http://projecteuler.net/index.php?section=problems&id=89 Problem 89] ==<br />
Develop a method to express Roman numerals in minimal form.<br />
<br />
Solution:<br />
<haskell><br />
replace ([], _) zs = zs<br />
replace _ [] = []<br />
replace (xs, ys) zzs@(z:zs)<br />
| xs == lns = ys ++ rns<br />
| otherwise = z : replace (xs, ys) zs<br />
where<br />
(lns, rns) = splitAt (length xs) zzs<br />
<br />
problem_89 = <br />
print . difference . words =<< readFile "roman.txt"<br />
where<br />
difference xs = sum (map length xs) - sum (map (length . reduce) xs)<br />
reduce xs = foldl (flip replace) xs [("DCCCC","CM"), ("CCCC","CD"), <br />
("LXXXX","XC"), ("XXXX","XL"), <br />
("VIIII","IX"), ("IIII","IV")]<br />
</haskell><br />
<br />
== [http://projecteuler.net/index.php?section=problems&id=90 Problem 90] ==<br />
An unexpected way of using two cubes to make a square.<br />
<br />
Solution:<br />
<br />
Basic brute force: generate all possible die combinations and check each one to see if we can make all the necessary squares. Runs very fast even for brute force.<br />
<br />
<haskell><br />
-- all lists consisting of n elements from the given list<br />
choose 0 _ = [[]]<br />
choose _ [] = []<br />
choose n (x:xs) =<br />
( map ( x : ) ( choose ( n - 1 ) xs ) ) ++ ( choose n xs )<br />
<br />
-- cross product helper function<br />
cross f xs ys = [ f x y | x <- xs, y <- ys ]<br />
<br />
-- all dice combinations<br />
-- substitute 'k' for both '6' and '9' to make comparisons easier<br />
dice = cross (,) ( choose 6 "012345k78k" ) ( choose 6 "012345k78k" )<br />
<br />
-- can we make all square numbers from the two dice<br />
-- again, substitute 'k' for '6' and '9'<br />
makeSquares dice =<br />
all ( makeSquare dice ) [ "01", "04", "0k", "1k", "25", "3k", "4k", "k4", "81" ]<br />
<br />
-- can we make this square from the two dice<br />
makeSquare ( xs, ys ) [ d1, d2 ] =<br />
( ( ( d1 `elem` xs ) && ( d2 `elem` ys ) ) || ( ( d2 `elem` xs ) && ( d1 `elem` ys ) ) )<br />
<br />
problem_90 =<br />
( `div` 2 ) . -- because each die combinations will appear twice<br />
length .<br />
filter makeSquares<br />
$ dice<br />
</haskell></div>Scvalexhttps://wiki.haskell.org/index.php?title=Euler_problems/81_to_90&diff=21894Euler problems/81 to 902008-07-22T14:40:26Z<p>Scvalex: added another solution to problem 81</p>
<hr />
<div>== [http://projecteuler.net/index.php?section=problems&id=81 Problem 81] ==<br />
Find the minimal path sum from the top left to the bottom right by moving right and down.<br />
<br />
Solution:<br />
<haskell><br />
import Data.List (unfoldr)<br />
<br />
columns s = <br />
unfoldr f s<br />
where<br />
f [] = Nothing<br />
f xs = Just $ (\(a,b) -> (read a, drop 1 b)) $ break (==',') xs<br />
<br />
firstLine ls = scanl1 (+) ls<br />
<br />
nextLine pl [] = pl<br />
nextLine pl (n:nl) = <br />
nextLine p' nl<br />
where<br />
p' = nextCell (head pl) pl n<br />
nextCell _ [] [] = []<br />
nextCell pc (p:pl) (n:nl) = <br />
pc' : nextCell pc' pl nl<br />
where pc' = n + min p pc<br />
<br />
minSum (p:nl) = <br />
last $ nextLine p' nl<br />
where<br />
p' = firstLine p<br />
<br />
problem_81 c = minSum $ map columns $ lines c<br />
main=do<br />
f<-readFile "matrix.txt"<br />
print$problem_81 f<br />
</haskell><br />
<br />
Another solution that used Data.Array:<br />
<haskell><br />
import Data.Array<br />
<br />
problem_81 :: String -> Integer<br />
problem_81 txt = b ! (0, 0)<br />
where<br />
a = listArray ((0,0), (79,79)) . concatMap read . map (\xs -> '[' : xs ++ "]") . lines $ txt<br />
b = array ((0,0), (80,80)) $ [((80, i), 0) | i <- [0..80]]<br />
++ [((i, 80), 0) | i <- [0..80]]<br />
++ [((79, i), a ! (79, i) + b ! (79, i+1)) | i <- [79,78..0]]<br />
++ [((i, 79), a ! (i, 79) + b ! (i+1, 79)) | i <- [79,78..0]]<br />
++ [((i, j), a ! (i,j) + min (b ! (i+1, j)) (b ! (i, j+1))) | i <- [78,77..0], j <- [78,77..0]]<br />
<br />
main :: IO ()<br />
main = do<br />
txt <- readFile "matrix.txt"<br />
print $ problem_81 txt<br />
</haskell><br />
<br />
I am offering this solution not because it is particularly<br />
brilliant, but because it introduces the wonderful fgl Graph<br />
Library written by Martin Erwig. Martin's Data.Graph.Inductive<br />
library allows you to solve problems 81,82, and 83 with exactly<br />
the same code, and best of all, little or no thinking. The idea<br />
is to convert the n by n matrix into an n^2 by n^2 graph whose<br />
edges depend on the allowed paths. Fortunately these graphs are<br />
very sparse, averaging only 4 edges per node. This allows us to<br />
use the Dijkstra algorithm to find the shortest path in a graph.<br />
<br />
The only slightly dodgy bit is problem 82, where we must find<br />
the shortest path from the first column to the last column. In<br />
order to avoid recomputing the Dijkstra algorithm over and over<br />
again, you have to be a little careful in the order of<br />
evaluation. I used spTree function from<br />
Data.Graph.Inductive.Query.SP which generated the shortest path<br />
tree from a given initial node to all other nodes. I then map<br />
over this tree with the nodes of the graph that are in the last<br />
column. The tree only needs to be calculated once for each<br />
element in the first column, rather than for every pair (i,j).<br />
This reduces the running time by a factor of n.<br />
Henry Laxen -- Apr. 27, 2008<br />
<br />
<haskell><br />
import Data.Graph.Inductive<br />
import Data.Graph.Inductive.Graph<br />
import Data.Graph.Inductive.Query.SP<br />
import Data.Graph.Inductive.Internal.RootPath<br />
import Data.List (unfoldr)<br />
<br />
type Matrix = [[Int]]<br />
type IJ = (Int, Int)<br />
<br />
connect81, connect82, connect83 :: [IJ]<br />
connect81 = [(1,0),(0,1)]<br />
connect82 = [(-1,0),(1,0),(0,1)]<br />
connect83 = [(-1,0),(0,-1),(1,0),(0,1)]<br />
<br />
dimensions :: Matrix -> IJ<br />
dimensions matrix = (length matrix, length (matrix!!0))<br />
<br />
ijToindex :: Matrix -> IJ -> Int<br />
ijToindex matrix (i,j) = i*rows + j<br />
where (rows,cols) = dimensions matrix<br />
<br />
indexToij :: Matrix -> Int -> IJ<br />
indexToij matrix index = divMod index rows<br />
where (rows,cols) = dimensions matrix<br />
<br />
ijValid :: Matrix -> [IJ] -> [IJ]<br />
ijValid matrix ijs = filter f ijs<br />
where (rows,cols) = dimensions matrix<br />
f (i,j) = i >= 0 && i < rows && j >= 0 && j < cols<br />
<br />
ijPlus :: IJ -> IJ -> IJ<br />
ijPlus (i1,j1) (i2,j2) = ((i1+i2),(j1+j2)) <br />
<br />
mEdges :: Matrix -> [IJ] -> IJ -> [(Int, Int, Int)]<br />
mEdges matrix connectL (i,j) =<br />
let ijs = ijValid matrix $ map (ijPlus (i,j)) connectL<br />
in map (\(x,y) -> (ijToindex matrix (i,j), <br />
ijToindex matrix (x,y),<br />
matrix!!x!!y)) ijs<br />
<br />
mGraph :: Matrix -> [IJ] -> Gr IJ Int<br />
mGraph matrix connectL =<br />
let (rows,cols) = dimensions matrix<br />
ijs = [(i,j) | i<-[0..(rows-1)], j<-[0..(cols-1)]]<br />
mnodes = map (\(x,y) -> (ijToindex matrix (x,y) ,(x,y))) ijs<br />
medges = concatMap (mEdges matrix connectL) ijs<br />
-- Everything written above is leading up to this line,<br />
-- namely transforming an m x n matrix into an mn x mn graph <br />
in mkGraph mnodes medges<br />
<br />
<br />
mSPlen :: Matrix -> [IJ] -> [IJ] -> [IJ] -> ((IJ, IJ), Int)<br />
mSPlen matrix connectL from to =<br />
let (rows,cols) = dimensions matrix<br />
mx (i,j) = matrix!!i!!j<br />
ijI = ijToindex matrix<br />
gr = mGraph matrix connectL<br />
spTrees = map (\x -> (x,spTree (ijI x) gr)) from<br />
distance (i,j) = getDistance (ijI (i,j)) <br />
distances = concatMap (\x -> map (\y -> ((fst x,y),<br />
(distance y (snd x)) + mx (fst x))) to) spTrees<br />
in foldl1 (\x y -> if snd x < snd y then x else y) distances<br />
<br />
debug = False <br />
mName = if debug then "small_matrix.txt" else "matrix.txt"<br />
<br />
columns :: [Char] -> [Int]<br />
columns s = <br />
unfoldr f s<br />
where<br />
f [] = Nothing<br />
f xs = Just $ (\(a,b) -> (read a, drop 1 b)) $ break (==',') xs<br />
<br />
main = do<br />
f<-readFile mName<br />
let matrix = map columns $ lines f<br />
(rows,cols) = dimensions matrix<br />
firstColumn = [(i,0) | i<-[0..(rows-1)]]<br />
lastColumn = [(i,(rows-1)) | i<-[0..(rows-1)]]<br />
topLeft = [(0,0)]<br />
bottomRight = [(rows-1,cols-1)]<br />
putStrLn $ "Problem 81: " ++ <br />
(show $ mSPlen matrix connect81 topLeft bottomRight)<br />
putStrLn $ "Problem 82: " ++ <br />
(show $ mSPlen matrix connect82 firstColumn lastColumn)<br />
putStrLn $ "Problem 83: " ++ <br />
(show $ mSPlen matrix connect83 topLeft bottomRight)<br />
<br />
<br />
</haskell><br />
<br />
<br />
<br />
== [http://projecteuler.net/index.php?section=problems&id=82 Problem 82] ==<br />
Find the minimal path sum from the left column to the right column.<br />
<br />
Solution:<br />
<haskell><br />
import Data.List<br />
import qualified Data.Map as M<br />
import Data.Array<br />
<br />
minPathSum xs t= <br />
stepPath M.empty $ M.singleton t $ arr ! t<br />
where <br />
len = genericLength $ head xs<br />
ys = concat $ transpose xs<br />
arr = listArray ((1, 1), (len, len)) ys<br />
nil = ((0,0),0)<br />
stepPath ds as <br />
|fs2 p1==len =snd p1 <br />
|fs2 p2==len =snd p2 <br />
|fs2 p3==len =snd p3 <br />
|otherwise=stepPath ds' as3<br />
where<br />
fs2=fst.fst<br />
((i, j), cost) = <br />
minimumBy (\(_,a) (_,b) -> compare a b) $ M.assocs as<br />
tas = M.delete (i,j) as<br />
(p1, as1) = if i == len then (nil, tas) else check (i+1, j) tas<br />
(p2, as2) = if j == len then (nil, as1) else check (i, j+1) as1<br />
(p3, as3) = if j == 1 then (nil, as2) else check (i, j-1) as2<br />
check pos zs =<br />
if pos `M.member` tas || pos `M.member` ds <br />
then (nil, zs)<br />
else (entry, uncurry M.insert entry $ zs)<br />
where<br />
entry = (pos, cost + arr ! pos) <br />
ds' = M.insert (i, j) cost ds<br />
<br />
main=do<br />
let parse = map (read . ("["++) . (++"]")) . words<br />
a<-readFile "matrix.txt"<br />
let s=parse a<br />
let m=minimum[p|a<-[1..80],let p=minPathSum s (1,a)]<br />
appendFile "p82.log"$show m<br />
<br />
problem_82 = main<br />
</haskell><br />
<br />
== [http://projecteuler.net/index.php?section=problems&id=83 Problem 83] ==<br />
Find the minimal path sum from the top left to the bottom right by moving left, right, up, and down.<br />
<br />
Solution:<br />
<br />
A very verbose solution based on the Dijkstra algorithm. Infinity could be represented by any large value instead of the data type Distance. Also, some equality and ordering tests are not really correct. To be semantically correct, I think infinity == infinity should not be True and infinity > infinity should fail. But for this script's purpose it works like this.<br />
<br />
<haskell><br />
import Array (Array, listArray, bounds, inRange, assocs, (!))<br />
import qualified Data.Map as M <br />
(fromList, Map, foldWithKey, <br />
lookup, null, delete, insert, empty, update)<br />
import Data.List (unfoldr)<br />
import Control.Monad.State (State, execState, get, put)<br />
import Data.Maybe (fromJust, fromMaybe)<br />
<br />
type Weight = Integer<br />
<br />
data Distance = D Weight | Infinity<br />
deriving (Show)<br />
<br />
instance Eq Distance where<br />
(==) Infinity Infinity = True<br />
(==) (D a) (D b) = a == b<br />
(==) _ _ = False<br />
<br />
instance Ord Distance where<br />
compare Infinity Infinity = EQ<br />
compare Infinity (D _) = GT<br />
compare (D _) Infinity = LT<br />
compare (D a) (D b) = compare a b<br />
<br />
data (Eq n, Num w) => Arc n w = A {node :: n, weight :: w}<br />
deriving (Show)<br />
<br />
type Index = (Int, Int)<br />
type NodeMap = M.Map Index Distance<br />
type Matrix = Array Index Weight<br />
type Path = Arc Index Weight<br />
type PathMap = M.Map Index [Path]<br />
<br />
data Queues = Q {input :: NodeMap, output :: NodeMap, pathMap :: PathMap}<br />
deriving (Show)<br />
<br />
listToMatrix :: [[Weight]] -> Matrix<br />
listToMatrix xs = listArray ((1,1),(cols,rows)) $ concat $ xs<br />
where<br />
cols = length $ head xs<br />
rows = length xs<br />
<br />
directions :: [Index]<br />
directions = [(0,-1), (0,1), (-1,0), (1,0)]<br />
<br />
add :: (Num a) => (a, a) -> (a, a) -> (a, a)<br />
add (a,b) (a', b') = (a+a',b+b')<br />
<br />
arcs :: Matrix -> Index -> [Path]<br />
arcs a idx = do<br />
d <- directions<br />
let n = add idx d<br />
if (inRange (bounds a) n) then<br />
return $ A n (a ! n)<br />
else<br />
fail "out of bounds"<br />
<br />
paths :: Matrix -> PathMap<br />
paths a = M.fromList $ map (\(idx,_) -> (idx, arcs a idx)) $ assocs a<br />
<br />
nodes :: Matrix -> NodeMap<br />
nodes a = <br />
M.fromList $ (\((i,_):xs) -> (i, D (a ! (1,1))):xs) $ <br />
map (\(idx,_) -> (idx, Infinity)) $ assocs a<br />
<br />
extractMin :: NodeMap -> (NodeMap, (Index, Distance))<br />
extractMin m = (M.delete (fst minNode) m, minNode)<br />
where<br />
minNode = M.foldWithKey mini ((0,0), Infinity) m<br />
mini i' v' (i,v)<br />
| v' < v = (i', v')<br />
| otherwise = (i,v)<br />
<br />
dijkstra :: State Queues ()<br />
dijkstra = do<br />
Q i o am <- get<br />
let (i', n) = extractMin i<br />
let o' = M.insert (fst n) (snd n) o<br />
let i'' = updateNodes n am i'<br />
put $ Q i'' o' am<br />
if M.null i'' then return () else dijkstra<br />
<br />
updateNodes :: (Index, Distance) -> PathMap -> NodeMap -> NodeMap<br />
updateNodes (i, D d) am nm = foldr f nm ds<br />
where<br />
ds = fromJust $ M.lookup i am<br />
f :: Path -> NodeMap -> NodeMap<br />
f (A i' w) m = fromMaybe m val<br />
where<br />
val = do<br />
v <- M.lookup i' m<br />
if (D $ d+w) < v then<br />
return $ M.update (const $ Just $ D (d+w)) i' m<br />
else return m<br />
<br />
shortestPaths :: Matrix -> NodeMap<br />
shortestPaths xs = output $ dijkstra `execState` (Q n M.empty a)<br />
where<br />
n = nodes xs<br />
a = paths xs<br />
<br />
problem_83 :: [[Weight]] -> Weight<br />
problem_83 xs = jd $ M.lookup idx $ shortestPaths matrix<br />
where<br />
matrix = listToMatrix xs<br />
idx = snd $ bounds matrix<br />
jd (Just (D d)) = d<br />
main=do<br />
f<-readFile "matrix.txt"<br />
let m=map sToInt $lines f<br />
print $problem_83 m<br />
split :: Char -> String -> [String]<br />
split = unfoldr . split'<br />
<br />
split' :: Char -> String -> Maybe (String, String)<br />
split' c l<br />
| null l = Nothing<br />
| otherwise = Just (h, drop 1 t)<br />
where (h, t) = span (/=c) l<br />
sToInt x=map ((+0).read) $split ',' x<br />
</haskell><br />
<br />
== [http://projecteuler.net/index.php?section=problems&id=84 Problem 84] ==<br />
In the game, Monopoly, find the three most popular squares when using two 4-sided dice.<br />
<br />
This may not be the shortest or the fastest implementation, but<br />
I hope it is one of the clearest. I have one comment about the<br />
experience of solving this problem that I would like to share<br />
with you. At first I thought I would have to make use of the<br />
Control.Monad.State library, but being relatively new to<br />
Haskell, I quickly found myself in the slough of type checker<br />
despond. It was then that I remembered that foldl/foldr can<br />
used instead of "State," and now I found myself in the celestial<br />
city of type checker heaven, with Haskell preventing me from<br />
making silly mistakes at every turn. HenryLaxen May 7, 2008<br />
<br />
<haskell><br />
import Data.Array.IArray<br />
import Data.List<br />
import Data.Ord<br />
import System.Random<br />
<br />
<br />
data Squares = <br />
GO | A1 | CC1 | A2 | T1 | R1 | B1 | CH1 | B2 | B3 | JAIL | <br />
C1 | U1 | C2 | C3 | R2 | D1 | CC2 | D2 | D3 | FP | <br />
E1 | CH2 | E2 | E3 | R3 | F1 | F2 | U2 | F3 | G2J | <br />
G1 | G2 | CC3 | G3 | R4 | CH3 | H1 | T2 | H2 <br />
deriving (Eq,Ord,Enum,Read,Show,Ix)<br />
<br />
type Roll = [Int]<br />
<br />
data Cards = GoTo Squares | R | U | Back3 | Other<br />
deriving (Eq,Ord,Read,Show)<br />
<br />
type Deck = [Cards]<br />
<br />
data GameState = GameState<br />
{ position :: Squares,<br />
doublesCount :: Int,<br />
chance :: [Cards],<br />
communityChest :: [Cards],<br />
history :: [Squares]<br />
} deriving (Eq,Ord,Read,Show)<br />
<br />
deckCommunityChest = [ GoTo JAIL, GoTo GO ] ++ replicate 14 Other<br />
deckChance = [ GoTo GO, GoTo JAIL, GoTo C1, <br />
GoTo E3, GoTo H2, GoTo R1] ++<br />
[ R, U, Back3] ++<br />
replicate 6 Other<br />
<br />
doubles :: Roll -> Bool<br />
doubles r = r!!0 == r!!1<br />
<br />
defaultGameState = GameState<br />
{ position = GO,<br />
doublesCount = 0,<br />
chance = deckChance,<br />
communityChest = deckCommunityChest,<br />
history = [GO]<br />
}<br />
<br />
takeCard :: Deck -> (Cards,Deck)<br />
takeCard cards = (card,deck)<br />
where card = head cards<br />
deck = tail cards ++ [card]<br />
<br />
nextR g = case position g of<br />
CH1 -> R2<br />
CH2 -> R3<br />
CH3 -> R1<br />
<br />
nextU g = case position g of <br />
CH1 -> U1<br />
CH2 -> U2<br />
CH3 -> U1<br />
<br />
doCommunityChest :: GameState -> GameState<br />
doCommunityChest g =<br />
let (card,deck) = takeCard (communityChest g)<br />
rotate g = g {communityChest = deck }<br />
cases = case card of<br />
GoTo sq -> g { position = sq }<br />
Other -> g <br />
in rotate cases<br />
<br />
doChance :: GameState -> GameState<br />
doChance g =<br />
let (card,deck) = takeCard (chance g)<br />
rotate g = g {chance = deck }<br />
cases = case card of<br />
GoTo sq -> g { position = sq}<br />
R -> g { position = nextR g }<br />
U -> g { position = nextU g }<br />
-- you might back up from CH3 to CC3 so checkForCards again<br />
Back3 -> checkForCards (g { position = position (newPosition g (-3))})<br />
Other -> g <br />
in rotate cases<br />
<br />
newPosition :: GameState -> Int -> GameState<br />
newPosition g n = g {position = toEnum $ <br />
(fromEnum (position g) + n) `mod` (fromEnum H2 + 1)}<br />
<br />
checkForCards :: GameState -> GameState<br />
checkForCards g <br />
| (position g) `elem` [CH1, CH2, CH3] = doChance g<br />
| (position g) `elem` [CC1, CC2, CC3] = doCommunityChest g<br />
| otherwise = g<br />
<br />
travel :: GameState -> [Int] -> GameState<br />
travel g roll = <br />
let value = sum roll<br />
checkDoubles <br />
| doubles roll && doublesCount g == 2 = <br />
g { position = JAIL,<br />
doublesCount = 0 }<br />
| doubles roll = move $ g { doublesCount = (doublesCount g) + 1}<br />
| otherwise = move $ g { doublesCount = 0}<br />
move g = newPosition g value<br />
checkForJail g<br />
| (position g) == G2J = g { position = JAIL }<br />
| otherwise = g<br />
saveHistory g = g { history = (position g) : (history g) }<br />
in saveHistory $ checkForCards $ checkForJail $ checkDoubles <br />
<br />
<br />
game :: GameState -> [Roll] -> GameState<br />
-- As an exercise in what a difference strictness can make<br />
-- compare the performance of this with replacing foldl' by foldl<br />
game g rolls = foldl' (\x y -> travel x y) g rolls<br />
<br />
statistics :: [Squares] -> [(Squares, Float)]<br />
statistics history = <br />
let a = accumArray (+) 0 (GO,H2) (zip history (repeat 1)) :: Array Squares Int<br />
b = assocs a<br />
c = reverse $ sortBy (comparing snd) b<br />
(sq,cnt) = unzip c -- wiki formatting bug, should be unzip c<br />
total = sum cnt<br />
stats = map (\x -> ((fromIntegral x) / (fromIntegral total) * 100)) cnt<br />
in take 3 $ zip sq stats<br />
<br />
<br />
r = [[1,1],[2,2],[2,2],[4,4]]<br />
t = game defaultGameState r -- useful for debugging<br />
<br />
pairs :: [a] -> [[a]]<br />
pairs [] = [[]]<br />
pairs (x:y:xs) = [[x,y]] ++ (pairs xs)<br />
<br />
<br />
dieSides :: (Int,Int)<br />
-- dieSides = (1,6)<br />
dieSides = (1,4)<br />
maxRolls = 100000<br />
<br />
main = do<br />
seed <- newStdGen<br />
let rolls = pairs (randomRs dieSides seed)<br />
stats = statistics (history (game defaultGameState <br />
(take maxRolls rolls)))<br />
result = map (\x -> fromEnum (fst x)) stats<br />
print (stats,result)<br />
<br />
</haskell><br />
== [http://projecteuler.net/index.php?section=problems&id=85 Problem 85] ==<br />
Investigating the number of rectangles in a rectangular grid.<br />
<br />
Solution:<br />
<haskell><br />
import List<br />
problem_85 = snd$head$sort <br />
[(k,a*b)|<br />
a<-[1..100],<br />
b<-[1..100],<br />
let k=abs (a*(a+1)*(b+1)*b-8000000)<br />
]<br />
</haskell><br />
<br />
== [http://projecteuler.net/index.php?section=problems&id=86 Problem 86] ==<br />
Exploring the shortest path from one corner of a cuboid to another.<br />
<br />
Solution:<br />
<haskell><br />
import Data.List<br />
isSquare x = <br />
(truncate $ sqrt $ fromIntegral x)^2 == x<br />
<br />
cube m = <br />
sum [ (a`div`2) - if a > m then (a - m -1) else 0|<br />
a <- [1..2*m],<br />
isSquare ((a)^2 + m2)<br />
]<br />
where<br />
m2 = m * m<br />
<br />
problem_86 =<br />
findIndex (>1000000) (scanl (+) 0 (map cube [1..]))<br />
</haskell><br />
<br />
== [http://projecteuler.net/index.php?section=problems&id=87 Problem 87] ==<br />
Investigating numbers that can be expressed as the sum of a prime square, cube, and fourth power?<br />
<br />
Solution:<br />
<haskell><br />
import List<br />
<br />
problem_87 = length expressible<br />
where limit = 50000000<br />
squares = takeWhile (<limit) (map (^2) primes)<br />
cubes = takeWhile (<limit) (map (^3) primes)<br />
fourths = takeWhile (<limit) (map (^4) primes)<br />
choices = [[s,c,f] | s <- squares, c <- cubes, f <- fourths]<br />
unique = map head . group . sort<br />
expressible = filter (<limit) . unique . map sum $ choices<br />
</haskell><br />
<br />
== [http://projecteuler.net/index.php?section=problems&id=88 Problem 88] ==<br />
Exploring minimal product-sum numbers for sets of different sizes.<br />
<br />
Solution:<br />
<haskell><br />
import Data.List<br />
import qualified Data.Set as S<br />
import qualified Data.Map as M<br />
<br />
primes = 2 : filter ((==1) . length . primeFactors) [3,5..] <br />
primeFactors n = factors n primes<br />
where factors n (p:ps) | p*p > n = [n]<br />
| n `mod` p == 0 = p : factors (n `div` p) (p:ps)<br />
| otherwise = factors n ps<br />
isPrime n | n > 1 = (==1) . length . primeFactors $ n<br />
| otherwise = False<br />
<br />
facts = concat . takeWhile valid . iterate facts' . (:[])<br />
where valid xs = length (head xs) > 1<br />
facts' = nub' . concatMap factsnext<br />
nub' = S.toList . S.fromList<br />
factsnext xs = <br />
let factsnext' [] = []<br />
factsnext' (y:ys) = map (form y) ys ++ factsnext' ys<br />
form a b = a*b : (delete b . delete a $ xs)<br />
in map sort . factsnext' $ xs <br />
<br />
problem_88 = sum' . extract . scanl addks M.empty . filter (not . isPrime) $ [2..]<br />
where extract = head . dropWhile (\nm -> M.size nm < 11999)<br />
sum' = S.fold (+) 0 . S.fromList . M.elems<br />
addks nm n = foldl (addk n) nm . facts . primeFactors $ n<br />
addk n nm ps =<br />
let k = length ps + n - sum ps<br />
kGood = k > 1 && k < 12001 && k `M.notMember` nm<br />
in if kGood then M.insert k n nm else nm<br />
</haskell><br />
<br />
== [http://projecteuler.net/index.php?section=problems&id=89 Problem 89] ==<br />
Develop a method to express Roman numerals in minimal form.<br />
<br />
Solution:<br />
<haskell><br />
replace ([], _) zs = zs<br />
replace _ [] = []<br />
replace (xs, ys) zzs@(z:zs)<br />
| xs == lns = ys ++ rns<br />
| otherwise = z : replace (xs, ys) zs<br />
where<br />
(lns, rns) = splitAt (length xs) zzs<br />
<br />
problem_89 = <br />
print . difference . words =<< readFile "roman.txt"<br />
where<br />
difference xs = sum (map length xs) - sum (map (length . reduce) xs)<br />
reduce xs = foldl (flip replace) xs [("DCCCC","CM"), ("CCCC","CD"), <br />
("LXXXX","XC"), ("XXXX","XL"), <br />
("VIIII","IX"), ("IIII","IV")]<br />
</haskell><br />
<br />
== [http://projecteuler.net/index.php?section=problems&id=90 Problem 90] ==<br />
An unexpected way of using two cubes to make a square.<br />
<br />
Solution:<br />
<br />
Basic brute force: generate all possible die combinations and check each one to see if we can make all the necessary squares. Runs very fast even for brute force.<br />
<br />
<haskell><br />
-- all lists consisting of n elements from the given list<br />
choose 0 _ = [[]]<br />
choose _ [] = []<br />
choose n (x:xs) =<br />
( map ( x : ) ( choose ( n - 1 ) xs ) ) ++ ( choose n xs )<br />
<br />
-- cross product helper function<br />
cross f xs ys = [ f x y | x <- xs, y <- ys ]<br />
<br />
-- all dice combinations<br />
-- substitute 'k' for both '6' and '9' to make comparisons easier<br />
dice = cross (,) ( choose 6 "012345k78k" ) ( choose 6 "012345k78k" )<br />
<br />
-- can we make all square numbers from the two dice<br />
-- again, substitute 'k' for '6' and '9'<br />
makeSquares dice =<br />
all ( makeSquare dice ) [ "01", "04", "0k", "1k", "25", "3k", "4k", "k4", "81" ]<br />
<br />
-- can we make this square from the two dice<br />
makeSquare ( xs, ys ) [ d1, d2 ] =<br />
( ( ( d1 `elem` xs ) && ( d2 `elem` ys ) ) || ( ( d2 `elem` xs ) && ( d1 `elem` ys ) ) )<br />
<br />
problem_90 =<br />
( `div` 2 ) . -- because each die combinations will appear twice<br />
length .<br />
filter makeSquares<br />
$ dice<br />
</haskell></div>Scvalexhttps://wiki.haskell.org/index.php?title=Euler_problems/71_to_80&diff=21892Euler problems/71 to 802008-07-22T13:37:51Z<p>Scvalex: replaced solution to problem 80 with one that a) is complete, b) works, c) doesn't look dreadful</p>
<hr />
<div>== [http://projecteuler.net/index.php?section=view&id=71 Problem 71] ==<br />
Listing reduced proper fractions in ascending order of size.<br />
<br />
Solution:<br />
<haskell><br />
-- http://mathworld.wolfram.com/FareySequence.html <br />
import Data.Ratio ((%), numerator,denominator)<br />
fareySeq a b<br />
|da2<=10^6=fareySeq a1 b<br />
|otherwise=na<br />
where<br />
na=numerator a<br />
nb=numerator b<br />
da=denominator a<br />
db=denominator b<br />
a1=(na+nb)%(da+db)<br />
da2=denominator a1<br />
problem_71=fareySeq (0%1) (3%7)<br />
</haskell><br />
<br />
== [http://projecteuler.net/index.php?section=view&id=72 Problem 72] ==<br />
How many elements would be contained in the set of reduced proper fractions for d ≤ 1,000,000?<br />
<br />
Solution:<br />
<br />
Using the [http://mathworld.wolfram.com/FareySequence.html Farey Sequence] method, the solution is the sum of phi (n) from 1 to 1000000.<br />
<haskell><br />
groups=1000<br />
eulerTotient n = product (map (\(p,i) -> p^(i-1) * (p-1)) factors)<br />
where factors = fstfac n<br />
fstfac x = [(head a ,length a)|a<-group$primeFactors x] <br />
p72 n= sum [eulerTotient x|x <- [groups*n+1..groups*(n+1)]]<br />
problem_72 = sum [p72 x|x <- [0..999]]<br />
</haskell><br />
<br />
== [http://projecteuler.net/index.php?section=view&id=73 Problem 73] ==<br />
How many fractions lie between 1/3 and 1/2 in a sorted set of reduced proper fractions?<br />
<br />
Solution:<br />
<br />
If you haven't done so already, read about Farey sequences in Wikipedia<br />
http://en.wikipedia.org/wiki/Farey_sequence, where you will learn about <br />
mediants. Then divide and conquer. The number of Farey ratios between<br />
(a, b) is 1 + the number between (a, mediant a b) + the number between<br />
(mediant a b, b). Henrylaxen 2008-03-04<br />
<br />
<haskell><br />
import Data.Ratio<br />
<br />
mediant :: (Integral a) => Ratio a -> Ratio a -> Ratio a<br />
mediant f1 f2 = (numerator f1 + numerator f2) % <br />
(denominator f1 + denominator f2)<br />
fareyCount :: (Integral a, Num t) => a -> (Ratio a, Ratio a) -> t<br />
fareyCount n (a,b) =<br />
let c = mediant a b<br />
in if (denominator c > n) then 0 else <br />
1 + (fareyCount n (a,c)) + (fareyCount n (c,b))<br />
<br />
problem_73 :: Integer<br />
problem_73 = fareyCount 10000 (1%3,1%2) <br />
</haskell><br />
<br />
<br />
== [http://projecteuler.net/index.php?section=view&id=74 Problem 74] ==<br />
Determine the number of factorial chains that contain exactly sixty non-repeating terms.<br />
<br />
Solution:<br />
<haskell><br />
import Data.List<br />
explode 0 = []<br />
explode n = n `mod` 10 : explode (n `quot` 10)<br />
<br />
chain 2 = 1<br />
chain 1 = 1<br />
chain 145 = 1<br />
chain 40585 = 1<br />
chain 169 = 3<br />
chain 363601 = 3<br />
chain 1454 = 3<br />
chain 871 = 2<br />
chain 45361 = 2<br />
chain 872 = 2<br />
chain 45362 = 2<br />
chain x = 1 + chain (sumFactDigits x)<br />
makeIncreas 1 minnum = [[a]|a<-[minnum..9]]<br />
makeIncreas digits minnum = [a:b|a<-[minnum ..9],b<-makeIncreas (digits-1) a]<br />
p74=<br />
sum[div p6 $countNum a|<br />
a<-tail$makeIncreas 6 1,<br />
let k=digitToN a,<br />
chain k==60<br />
]<br />
where<br />
p6=facts!! 6<br />
sumFactDigits = foldl' (\a b -> a + facts !! b) 0 . explode<br />
factorial n = if n == 0 then 1 else n * factorial (n - 1)<br />
digitToN = foldl' (\a b -> 10*a + b) 0 .dropWhile (==0)<br />
facts = scanl (*) 1 [1..9]<br />
countNum xs=ys<br />
where<br />
ys=product$map (factorial.length)$group xs <br />
problem_74= length[k|k<-[1..9999],chain k==60]+p74<br />
test = print $ [a|a<-tail$makeIncreas 6 0,let k=digitToN a,chain k==60]<br />
</haskell><br />
== [http://projecteuler.net/index.php?section=view&id=75 Problem 75] ==<br />
Find the number of different lengths of wire can that can form a right angle triangle in only one way.<br />
<br />
Solution:<br />
<haskell><br />
import Data.Array<br />
<br />
triangs :: [Int]<br />
triangs = [p | n <- [2..1000],<br />
m <- [1..n-1],<br />
gcd m n == 1,<br />
odd (m+n),<br />
let p = 2 * (n^2 + m*n),<br />
p <= 2*10^6]<br />
<br />
problem_75 :: Int<br />
problem_75 = length<br />
$ filter (\(_, c) -> c == 1)<br />
$ assocs<br />
$ (\ns -> accumArray (+) 0 (1, 2*10^6) [(n, 1) | n <- ns, inRange (1, 2*10^6) n])<br />
$ concatMap (\n -> takeWhile (<=2*10^6) [n,2*n..]) triangs<br />
</haskell><br />
<br />
== [http://projecteuler.net/index.php?section=view&id=76 Problem 76] ==<br />
How many different ways can one hundred be written as a sum of at least two positive integers?<br />
<br />
Solution:<br />
<br />
Here is a simpler solution: For each n, we create the list of the number of partitions of n<br />
whose lowest number is i, for i=1..n. We build up the list of these lists for n=0..100.<br />
<haskell><br />
build x = (map sum (zipWith drop [0..] x) ++ [1]) : x<br />
problem_76 = (sum $ head $ iterate build [] !! 100) - 1<br />
</haskell><br />
<br />
== [http://projecteuler.net/index.php?section=view&id=77 Problem 77] ==<br />
What is the first value which can be written as the sum of primes in over five thousand different ways?<br />
<br />
Solution:<br />
<br />
Brute force but still finds the solution in less than one second.<br />
<haskell><br />
counter = foldl (\without p -><br />
let (poor,rich) = splitAt p without<br />
with = poor ++ <br />
zipWith (+) with rich<br />
in with<br />
) (1 : repeat 0)<br />
<br />
problem_77 = <br />
find ((>5000) . (ways !!)) $ [1..]<br />
where<br />
ways = counter $ take 100 primes<br />
</haskell><br />
<br />
== [http://projecteuler.net/index.php?section=view&id=78 Problem 78] ==<br />
Investigating the number of ways in which coins can be separated into piles.<br />
<br />
Solution:<br />
<haskell><br />
import Data.Array<br />
<br />
partitions :: Array Int Integer<br />
partitions = <br />
array (0,1000000) $ <br />
(0,1) : <br />
[(n,sum [s * partitions ! p|<br />
(s,p) <- zip signs $ parts n])|<br />
n <- [1..1000000]]<br />
where<br />
signs = cycle [1,1,(-1),(-1)]<br />
suite = map penta $ concat [[n,(-n)]|n <- [1..]]<br />
penta n = n*(3*n - 1) `div` 2<br />
parts n = takeWhile (>= 0) [n-x| x <- suite]<br />
<br />
problem_78 :: Int<br />
problem_78 = <br />
head $ filter (\x -> (partitions ! x) `mod` 1000000 == 0) [1..]<br />
</haskell><br />
<br />
== [http://projecteuler.net/index.php?section=view&id=79 Problem 79] ==<br />
By analysing a user's login attempts, can you determine the secret numeric passcode?<br />
<br />
Solution:<br />
<haskell><br />
import Data.Char (digitToInt, intToDigit)<br />
import Data.Graph (buildG, topSort)<br />
import Data.List (intersect)<br />
<br />
p79 file= <br />
(+0)$read . intersect graphWalk $ usedDigits<br />
where<br />
usedDigits = intersect "0123456789" $ file<br />
edges = concat . map (edgePair . map digitToInt) . words $ file<br />
graphWalk = map intToDigit . topSort . buildG (0, 9) $ edges<br />
edgePair [x, y, z] = [(x, y), (y, z)]<br />
edgePair _ = undefined<br />
<br />
problem_79 = do<br />
f<-readFile "keylog.txt"<br />
print $p79 f<br />
</haskell><br />
<br />
== [http://projecteuler.net/index.php?section=view&id=80 Problem 80] ==<br />
Calculating the digital sum of the decimal digits of irrational square roots.<br />
<br />
This solution uses binary search to find the square root of a large Integer:<br />
<haskell><br />
import Data.Char (digitToInt)<br />
<br />
intSqrt :: Integer -> Integer<br />
intSqrt n = bsearch 1 n<br />
where<br />
bsearch l u = let m = (l+u) `div` 2<br />
m2 = m^2<br />
in if u <= l<br />
then m<br />
else if m2 < n<br />
then bsearch (m+1) u<br />
else bsearch l m<br />
<br />
problem_80 :: Int<br />
problem_80 = sum [f r | a <- [1..100],<br />
let x = a * e,<br />
let r = intSqrt x,<br />
r*r /= x]<br />
where<br />
e = 10^202<br />
f = sum . take 100 . map digitToInt . show<br />
</haskell></div>Scvalexhttps://wiki.haskell.org/index.php?title=Euler_problems/71_to_80&diff=21841Euler problems/71 to 802008-07-18T14:53:53Z<p>Scvalex: Solution to prob75 was wrong. Replaced it.</p>
<hr />
<div>== [http://projecteuler.net/index.php?section=view&id=71 Problem 71] ==<br />
Listing reduced proper fractions in ascending order of size.<br />
<br />
Solution:<br />
<haskell><br />
-- http://mathworld.wolfram.com/FareySequence.html <br />
import Data.Ratio ((%), numerator,denominator)<br />
fareySeq a b<br />
|da2<=10^6=fareySeq a1 b<br />
|otherwise=na<br />
where<br />
na=numerator a<br />
nb=numerator b<br />
da=denominator a<br />
db=denominator b<br />
a1=(na+nb)%(da+db)<br />
da2=denominator a1<br />
problem_71=fareySeq (0%1) (3%7)<br />
</haskell><br />
<br />
== [http://projecteuler.net/index.php?section=view&id=72 Problem 72] ==<br />
How many elements would be contained in the set of reduced proper fractions for d ≤ 1,000,000?<br />
<br />
Solution:<br />
<br />
Using the [http://mathworld.wolfram.com/FareySequence.html Farey Sequence] method, the solution is the sum of phi (n) from 1 to 1000000.<br />
<haskell><br />
groups=1000<br />
eulerTotient n = product (map (\(p,i) -> p^(i-1) * (p-1)) factors)<br />
where factors = fstfac n<br />
fstfac x = [(head a ,length a)|a<-group$primeFactors x] <br />
p72 n= sum [eulerTotient x|x <- [groups*n+1..groups*(n+1)]]<br />
problem_72 = sum [p72 x|x <- [0..999]]<br />
</haskell><br />
<br />
== [http://projecteuler.net/index.php?section=view&id=73 Problem 73] ==<br />
How many fractions lie between 1/3 and 1/2 in a sorted set of reduced proper fractions?<br />
<br />
Solution:<br />
<br />
If you haven't done so already, read about Farey sequences in Wikipedia<br />
http://en.wikipedia.org/wiki/Farey_sequence, where you will learn about <br />
mediants. Then divide and conquer. The number of Farey ratios between<br />
(a, b) is 1 + the number between (a, mediant a b) + the number between<br />
(mediant a b, b). Henrylaxen 2008-03-04<br />
<br />
<haskell><br />
import Data.Ratio<br />
<br />
mediant :: (Integral a) => Ratio a -> Ratio a -> Ratio a<br />
mediant f1 f2 = (numerator f1 + numerator f2) % <br />
(denominator f1 + denominator f2)<br />
fareyCount :: (Integral a, Num t) => a -> (Ratio a, Ratio a) -> t<br />
fareyCount n (a,b) =<br />
let c = mediant a b<br />
in if (denominator c > n) then 0 else <br />
1 + (fareyCount n (a,c)) + (fareyCount n (c,b))<br />
<br />
problem_73 :: Integer<br />
problem_73 = fareyCount 10000 (1%3,1%2) <br />
</haskell><br />
<br />
<br />
== [http://projecteuler.net/index.php?section=view&id=74 Problem 74] ==<br />
Determine the number of factorial chains that contain exactly sixty non-repeating terms.<br />
<br />
Solution:<br />
<haskell><br />
import Data.List<br />
explode 0 = []<br />
explode n = n `mod` 10 : explode (n `quot` 10)<br />
<br />
chain 2 = 1<br />
chain 1 = 1<br />
chain 145 = 1<br />
chain 40585 = 1<br />
chain 169 = 3<br />
chain 363601 = 3<br />
chain 1454 = 3<br />
chain 871 = 2<br />
chain 45361 = 2<br />
chain 872 = 2<br />
chain 45362 = 2<br />
chain x = 1 + chain (sumFactDigits x)<br />
makeIncreas 1 minnum = [[a]|a<-[minnum..9]]<br />
makeIncreas digits minnum = [a:b|a<-[minnum ..9],b<-makeIncreas (digits-1) a]<br />
p74=<br />
sum[div p6 $countNum a|<br />
a<-tail$makeIncreas 6 1,<br />
let k=digitToN a,<br />
chain k==60<br />
]<br />
where<br />
p6=facts!! 6<br />
sumFactDigits = foldl' (\a b -> a + facts !! b) 0 . explode<br />
factorial n = if n == 0 then 1 else n * factorial (n - 1)<br />
digitToN = foldl' (\a b -> 10*a + b) 0 .dropWhile (==0)<br />
facts = scanl (*) 1 [1..9]<br />
countNum xs=ys<br />
where<br />
ys=product$map (factorial.length)$group xs <br />
problem_74= length[k|k<-[1..9999],chain k==60]+p74<br />
test = print $ [a|a<-tail$makeIncreas 6 0,let k=digitToN a,chain k==60]<br />
</haskell><br />
== [http://projecteuler.net/index.php?section=view&id=75 Problem 75] ==<br />
Find the number of different lengths of wire can that can form a right angle triangle in only one way.<br />
<br />
Solution:<br />
<haskell><br />
import Data.Array<br />
<br />
triangs :: [Int]<br />
triangs = [p | n <- [2..1000],<br />
m <- [1..n-1],<br />
gcd m n == 1,<br />
odd (m+n),<br />
let p = 2 * (n^2 + m*n),<br />
p <= 2*10^6]<br />
<br />
problem_75 :: Int<br />
problem_75 = length<br />
$ filter (\(_, c) -> c == 1)<br />
$ assocs<br />
$ (\ns -> accumArray (+) 0 (1, 2*10^6) [(n, 1) | n <- ns, inRange (1, 2*10^6) n])<br />
$ concatMap (\n -> takeWhile (<=2*10^6) [n,2*n..]) triangs<br />
</haskell><br />
<br />
== [http://projecteuler.net/index.php?section=view&id=76 Problem 76] ==<br />
How many different ways can one hundred be written as a sum of at least two positive integers?<br />
<br />
Solution:<br />
<br />
Here is a simpler solution: For each n, we create the list of the number of partitions of n<br />
whose lowest number is i, for i=1..n. We build up the list of these lists for n=0..100.<br />
<haskell><br />
build x = (map sum (zipWith drop [0..] x) ++ [1]) : x<br />
problem_76 = (sum $ head $ iterate build [] !! 100) - 1<br />
</haskell><br />
<br />
== [http://projecteuler.net/index.php?section=view&id=77 Problem 77] ==<br />
What is the first value which can be written as the sum of primes in over five thousand different ways?<br />
<br />
Solution:<br />
<br />
Brute force but still finds the solution in less than one second.<br />
<haskell><br />
counter = foldl (\without p -><br />
let (poor,rich) = splitAt p without<br />
with = poor ++ <br />
zipWith (+) with rich<br />
in with<br />
) (1 : repeat 0)<br />
<br />
problem_77 = <br />
find ((>5000) . (ways !!)) $ [1..]<br />
where<br />
ways = counter $ take 100 primes<br />
</haskell><br />
<br />
== [http://projecteuler.net/index.php?section=view&id=78 Problem 78] ==<br />
Investigating the number of ways in which coins can be separated into piles.<br />
<br />
Solution:<br />
<haskell><br />
import Data.Array<br />
<br />
partitions :: Array Int Integer<br />
partitions = <br />
array (0,1000000) $ <br />
(0,1) : <br />
[(n,sum [s * partitions ! p|<br />
(s,p) <- zip signs $ parts n])|<br />
n <- [1..1000000]]<br />
where<br />
signs = cycle [1,1,(-1),(-1)]<br />
suite = map penta $ concat [[n,(-n)]|n <- [1..]]<br />
penta n = n*(3*n - 1) `div` 2<br />
parts n = takeWhile (>= 0) [n-x| x <- suite]<br />
<br />
problem_78 :: Int<br />
problem_78 = <br />
head $ filter (\x -> (partitions ! x) `mod` 1000000 == 0) [1..]<br />
</haskell><br />
<br />
== [http://projecteuler.net/index.php?section=view&id=79 Problem 79] ==<br />
By analysing a user's login attempts, can you determine the secret numeric passcode?<br />
<br />
Solution:<br />
<haskell><br />
import Data.Char (digitToInt, intToDigit)<br />
import Data.Graph (buildG, topSort)<br />
import Data.List (intersect)<br />
<br />
p79 file= <br />
(+0)$read . intersect graphWalk $ usedDigits<br />
where<br />
usedDigits = intersect "0123456789" $ file<br />
edges = concat . map (edgePair . map digitToInt) . words $ file<br />
graphWalk = map intToDigit . topSort . buildG (0, 9) $ edges<br />
edgePair [x, y, z] = [(x, y), (y, z)]<br />
edgePair _ = undefined<br />
<br />
problem_79 = do<br />
f<-readFile "keylog.txt"<br />
print $p79 f<br />
</haskell><br />
<br />
== [http://projecteuler.net/index.php?section=view&id=80 Problem 80] ==<br />
Calculating the digital sum of the decimal digits of irrational square roots.<br />
<br />
Solution:<br />
<haskell><br />
import Data.Char<br />
problem_80=<br />
sum [f x |<br />
a <- [1..100],<br />
x <- [intSqrt $ a * t],<br />
x * x /= a * t<br />
]<br />
where<br />
t=10^202<br />
f = (sum . take 100 . map (flip (-) (ord '0') .ord) . show)<br />
</haskell></div>Scvalexhttps://wiki.haskell.org/index.php?title=Euler_problems/51_to_60&diff=21728Euler problems/51 to 602008-07-10T15:01:06Z<p>Scvalex: added another solution to problem 57</p>
<hr />
<div>== [http://projecteuler.net/index.php?section=problems&id=51 Problem 51] ==<br />
Find the smallest prime which, by changing the same part of the number, can form eight different primes.<br />
<br />
Solution:<br />
<br />
millerRabinPrimality on the [[Prime_numbers]] page <br />
<br />
<haskell><br />
isPrime x<br />
|x==3=True<br />
|otherwise=millerRabinPrimality x 2<br />
ch='1'<br />
numChar n= sum [1|x<-show(n),x==ch]<br />
replace d c|c==ch=d<br />
|otherwise=c<br />
nextN repl n= (+0)$read $map repl $show n <br />
same n= [if isPrime$nextN (replace a) n then 1 else 0|a<-['1'..'9']]<br />
problem_51=head [n|<br />
n<-[100003,100005..999999],<br />
numChar n==3,<br />
(sum $same n)==8<br />
]<br />
</haskell><br />
<br />
== [http://projecteuler.net/index.php?section=problems&id=52 Problem 52] ==<br />
Find the smallest positive integer, x, such that 2x, 3x, 4x, 5x, and 6x, contain the same digits in some order.<br />
<br />
Solution:<br />
<haskell><br />
import List<br />
<br />
has_same_digits a b = (show a) \\ (show b) == []<br />
<br />
check n = all (has_same_digits n) (map (n*) [2..6])<br />
<br />
problem_52 = head $ filter check [1..]<br />
</haskell><br />
<br />
== [http://projecteuler.net/index.php?section=problems&id=53 Problem 53] ==<br />
How many values of C(n,r), for 1 ≤ n ≤ 100, exceed one-million?<br />
<br />
Solution:<br />
<haskell><br />
facs = reverse $ foldl (\y x->(head y) * x : y) [1] [1..100]<br />
comb (r,n) = facs!!n `div` (facs!!r * facs!!(n-r))<br />
perms = concat $ map (\x -> [(n,x) | n<-[1..x]]) [1..100]<br />
problem_53 = length $ filter (>1000000) $ map comb $ perms<br />
</haskell><br />
<br />
== [http://projecteuler.net/index.php?section=problems&id=54 Problem 54] ==<br />
How many hands did player one win in the [http://www.pokerroom.com poker games]?<br />
<br />
Solution:<br />
<br />
probably not the most straight forward way to do it.<br />
<br />
<haskell><br />
import Data.List<br />
import Data.Maybe<br />
import Control.Monad<br />
<br />
readCard [r,s] = (parseRank r, parseSuit s)<br />
where parseSuit = translate "SHDC"<br />
parseRank = translate "23456789TJQKA"<br />
translate from x = fromJust $ findIndex (==x) from<br />
<br />
solveHand hand = (handRank,tiebreak)<br />
where<br />
handRank<br />
| flush && straight = 9<br />
| hasKinds 4 = 8<br />
| all hasKinds [2,3] = 7<br />
| flush = 6<br />
| straight = 5<br />
| hasKinds 3 = 4<br />
| 1 < length (kind 2) = 3<br />
| hasKinds 2 = 2<br />
| otherwise = 1<br />
tiebreak = kind =<< [4,3,2,1]<br />
hasKinds = not . null . kind<br />
kind n = map head $ filter ((n==).length) $ group ranks<br />
ranks = reverse $ sort $ map fst hand<br />
flush = 1 == length (nub (map snd hand))<br />
straight = length (kind 1) == 5 && 4 == head ranks - last ranks<br />
<br />
gameLineToHands = splitAt 5 . map readCard . words<br />
p1won (a,b) = solveHand a > solveHand b<br />
<br />
problem_54 = do<br />
f <- readFile "poker.txt"<br />
let games = map gameLineToHands $ lines f<br />
wins = filter p1won games<br />
print $ length wins<br />
</haskell><br />
<br />
== [http://projecteuler.net/index.php?section=problems&id=55 Problem 55] ==<br />
How many Lychrel numbers are there below ten-thousand?<br />
<br />
Solution:<br />
<haskell><br />
reverseNum = read . reverse . show<br />
<br />
palindrome x =<br />
sx == reverse sx<br />
where<br />
sx = show x <br />
<br />
lychrel = <br />
not . any palindrome . take 50 . tail . iterate next<br />
where<br />
next x = x + reverseNum x<br />
<br />
problem_55 = length $ filter lychrel [1..10000]<br />
</haskell><br />
<br />
== [http://projecteuler.net/index.php?section=problems&id=56 Problem 56] ==<br />
Considering natural numbers of the form, a<sup>b</sup>, finding the maximum digital sum.<br />
<br />
Solution:<br />
<haskell><br />
digitalSum 0 = 0<br />
digitalSum n = <br />
let (d,m) = quotRem n 10 in m + digitalSum d <br />
<br />
problem_56 = <br />
maximum [digitalSum (a^b) | a <- [99], b <- [90..99]]<br />
</haskell><br />
<br />
Alternate solution:<br />
<haskell><br />
import Data.Char (digitToInt)<br />
<br />
digiSum :: Integer -> Int<br />
digiSum = sum . map digitToInt . show<br />
<br />
problem_56 :: Int<br />
problem_56 = maximum $ map digiSum [a^b | a <- [1..100], b <- [1..100]]<br />
</haskell><br />
<br />
== [http://projecteuler.net/index.php?section=problems&id=57 Problem 57] ==<br />
Investigate the expansion of the continued fraction for the square root of two.<br />
<br />
Solution:<br />
<haskell><br />
twoex = zip ns ds <br />
where<br />
ns = 3 : zipWith (\x y -> x + 2 * y) ns ds<br />
ds = 2 : zipWith (+) ns ds<br />
<br />
len = length . show<br />
<br />
problem_57 = <br />
length $ filter (\(n,d) -> len n > len d) $ take 1000 twoex<br />
</haskell><br />
<br />
The following solution is based on the observation that the fractions needed appear regularly in the repeating pattern _______$____$ where underscores are ignored and dollars are interesting fractions.<br />
<br />
<haskell><br />
calc :: Int -> Int<br />
calc n = nd13 * 2 + ((n-nd13*13) `div` 8)<br />
where<br />
nd13 = n `div` 13<br />
<br />
problem_57 :: Int<br />
problem_57 = calc 1000<br />
</haskell><br />
<br />
== [http://projecteuler.net/index.php?section=problems&id=58 Problem 58] ==<br />
Investigate the number of primes that lie on the diagonals of the spiral grid.<br />
<br />
Solution:<br />
<haskell><br />
isPrime x<br />
|x==3=True<br />
|otherwise=all id [millerRabinPrimality x n|n<-[2,3]]<br />
diag = 1:3:5:7:zipWith (+) diag [8,10..]<br />
problem_58 = <br />
result $ dropWhile tooBig $ drop 2 $ scanl primeRatio (0,0) diag<br />
where<br />
primeRatio (n,d) num = (if d `mod` 4 /= 0 && isPrime num then n+1 else n,d+1)<br />
tooBig (n,d) = n*10 >= d<br />
result ((_,d):_) = (d+2) `div` 4 * 2 + 1<br />
</haskell><br />
<br />
== [http://projecteuler.net/index.php?section=problems&id=59 Problem 59] ==<br />
Using a brute force attack, can you decrypt the cipher using XOR encryption?<br />
<br />
Solution:<br />
<haskell><br />
import Data.Bits<br />
import Data.Char<br />
import Data.List<br />
<br />
keys = [ [a,b,c] | a <- [97..122], b <- [97..122], c <- [97..122] ]<br />
allAlpha a = all (\k -> let a = ord k in (a >= 32 && a <= 122)) a<br />
howManySpaces x = length (elemIndices ' ' x)<br />
compareBy f x y = compare (f x) (f y)<br />
<br />
problem_59 = do<br />
s <- readFile "cipher1.txt"<br />
let <br />
cipher = (read ("[" ++ s ++ "]") :: [Int])<br />
decrypts = [ (map chr (zipWith xor (cycle key) cipher), map chr key) | key <- keys ]<br />
alphaDecrypts = filter (\(x,y) -> allAlpha x) decrypts<br />
message = maximumBy (\(x,y) (x',y') -> compareBy howManySpaces x x') alphaDecrypts<br />
asciisum = sum (map ord (fst message))<br />
putStrLn (show asciisum)<br />
</haskell><br />
<br />
== [http://projecteuler.net/index.php?section=problems&id=60 Problem 60] ==<br />
Find a set of five primes for which any two primes concatenate to produce another prime.<br />
<br />
Solution:<br />
<br />
Breadth first search that works on infinite lists. Breaks the 60 secs rule. This program finds the solution in 185 sec on my Dell D620 Laptop.<br />
<haskell><br />
problem_60 = print$sum $head solve <br />
isPrime x<br />
|x==3=True<br />
|otherwise=millerRabinPrimality x 2 <br />
<br />
solve = do<br />
a <- primesTo10000<br />
let m = f a $ dropWhile (<= a) primesTo10000<br />
b <- m<br />
let n = f b $ dropWhile (<= b) m<br />
c <- n<br />
let o = f c $ dropWhile (<= c) n<br />
d <- o<br />
let p = f d $ dropWhile (<= d) o<br />
e <- p<br />
return [a,b,c,d,e]<br />
where<br />
f x = filter (\y -> all id[isPrime $read $shows x $show y,<br />
isPrime $read $shows y $show x])<br />
primesTo10000 = 2:filter (isPrime) [3,5..9999]<br />
</haskell></div>Scvalexhttps://wiki.haskell.org/index.php?title=Euler_problems/51_to_60&diff=21727Euler problems/51 to 602008-07-10T14:27:01Z<p>Scvalex: added another solution to problem 56</p>
<hr />
<div>== [http://projecteuler.net/index.php?section=problems&id=51 Problem 51] ==<br />
Find the smallest prime which, by changing the same part of the number, can form eight different primes.<br />
<br />
Solution:<br />
<br />
millerRabinPrimality on the [[Prime_numbers]] page <br />
<br />
<haskell><br />
isPrime x<br />
|x==3=True<br />
|otherwise=millerRabinPrimality x 2<br />
ch='1'<br />
numChar n= sum [1|x<-show(n),x==ch]<br />
replace d c|c==ch=d<br />
|otherwise=c<br />
nextN repl n= (+0)$read $map repl $show n <br />
same n= [if isPrime$nextN (replace a) n then 1 else 0|a<-['1'..'9']]<br />
problem_51=head [n|<br />
n<-[100003,100005..999999],<br />
numChar n==3,<br />
(sum $same n)==8<br />
]<br />
</haskell><br />
<br />
== [http://projecteuler.net/index.php?section=problems&id=52 Problem 52] ==<br />
Find the smallest positive integer, x, such that 2x, 3x, 4x, 5x, and 6x, contain the same digits in some order.<br />
<br />
Solution:<br />
<haskell><br />
import List<br />
<br />
has_same_digits a b = (show a) \\ (show b) == []<br />
<br />
check n = all (has_same_digits n) (map (n*) [2..6])<br />
<br />
problem_52 = head $ filter check [1..]<br />
</haskell><br />
<br />
== [http://projecteuler.net/index.php?section=problems&id=53 Problem 53] ==<br />
How many values of C(n,r), for 1 ≤ n ≤ 100, exceed one-million?<br />
<br />
Solution:<br />
<haskell><br />
facs = reverse $ foldl (\y x->(head y) * x : y) [1] [1..100]<br />
comb (r,n) = facs!!n `div` (facs!!r * facs!!(n-r))<br />
perms = concat $ map (\x -> [(n,x) | n<-[1..x]]) [1..100]<br />
problem_53 = length $ filter (>1000000) $ map comb $ perms<br />
</haskell><br />
<br />
== [http://projecteuler.net/index.php?section=problems&id=54 Problem 54] ==<br />
How many hands did player one win in the [http://www.pokerroom.com poker games]?<br />
<br />
Solution:<br />
<br />
probably not the most straight forward way to do it.<br />
<br />
<haskell><br />
import Data.List<br />
import Data.Maybe<br />
import Control.Monad<br />
<br />
readCard [r,s] = (parseRank r, parseSuit s)<br />
where parseSuit = translate "SHDC"<br />
parseRank = translate "23456789TJQKA"<br />
translate from x = fromJust $ findIndex (==x) from<br />
<br />
solveHand hand = (handRank,tiebreak)<br />
where<br />
handRank<br />
| flush && straight = 9<br />
| hasKinds 4 = 8<br />
| all hasKinds [2,3] = 7<br />
| flush = 6<br />
| straight = 5<br />
| hasKinds 3 = 4<br />
| 1 < length (kind 2) = 3<br />
| hasKinds 2 = 2<br />
| otherwise = 1<br />
tiebreak = kind =<< [4,3,2,1]<br />
hasKinds = not . null . kind<br />
kind n = map head $ filter ((n==).length) $ group ranks<br />
ranks = reverse $ sort $ map fst hand<br />
flush = 1 == length (nub (map snd hand))<br />
straight = length (kind 1) == 5 && 4 == head ranks - last ranks<br />
<br />
gameLineToHands = splitAt 5 . map readCard . words<br />
p1won (a,b) = solveHand a > solveHand b<br />
<br />
problem_54 = do<br />
f <- readFile "poker.txt"<br />
let games = map gameLineToHands $ lines f<br />
wins = filter p1won games<br />
print $ length wins<br />
</haskell><br />
<br />
== [http://projecteuler.net/index.php?section=problems&id=55 Problem 55] ==<br />
How many Lychrel numbers are there below ten-thousand?<br />
<br />
Solution:<br />
<haskell><br />
reverseNum = read . reverse . show<br />
<br />
palindrome x =<br />
sx == reverse sx<br />
where<br />
sx = show x <br />
<br />
lychrel = <br />
not . any palindrome . take 50 . tail . iterate next<br />
where<br />
next x = x + reverseNum x<br />
<br />
problem_55 = length $ filter lychrel [1..10000]<br />
</haskell><br />
<br />
== [http://projecteuler.net/index.php?section=problems&id=56 Problem 56] ==<br />
Considering natural numbers of the form, a<sup>b</sup>, finding the maximum digital sum.<br />
<br />
Solution:<br />
<haskell><br />
digitalSum 0 = 0<br />
digitalSum n = <br />
let (d,m) = quotRem n 10 in m + digitalSum d <br />
<br />
problem_56 = <br />
maximum [digitalSum (a^b) | a <- [99], b <- [90..99]]<br />
</haskell><br />
<br />
Alternate solution:<br />
<haskell><br />
import Data.Char (digitToInt)<br />
<br />
digiSum :: Integer -> Int<br />
digiSum = sum . map digitToInt . show<br />
<br />
problem_56 :: Int<br />
problem_56 = maximum $ map digiSum [a^b | a <- [1..100], b <- [1..100]]<br />
</haskell><br />
<br />
== [http://projecteuler.net/index.php?section=problems&id=57 Problem 57] ==<br />
Investigate the expansion of the continued fraction for the square root of two.<br />
<br />
Solution:<br />
<haskell><br />
twoex = zip ns ds <br />
where<br />
ns = 3 : zipWith (\x y -> x + 2 * y) ns ds<br />
ds = 2 : zipWith (+) ns ds<br />
<br />
len = length . show<br />
<br />
problem_57 = <br />
length $ filter (\(n,d) -> len n > len d) $ take 1000 twoex<br />
</haskell><br />
<br />
== [http://projecteuler.net/index.php?section=problems&id=58 Problem 58] ==<br />
Investigate the number of primes that lie on the diagonals of the spiral grid.<br />
<br />
Solution:<br />
<haskell><br />
isPrime x<br />
|x==3=True<br />
|otherwise=all id [millerRabinPrimality x n|n<-[2,3]]<br />
diag = 1:3:5:7:zipWith (+) diag [8,10..]<br />
problem_58 = <br />
result $ dropWhile tooBig $ drop 2 $ scanl primeRatio (0,0) diag<br />
where<br />
primeRatio (n,d) num = (if d `mod` 4 /= 0 && isPrime num then n+1 else n,d+1)<br />
tooBig (n,d) = n*10 >= d<br />
result ((_,d):_) = (d+2) `div` 4 * 2 + 1<br />
</haskell><br />
<br />
== [http://projecteuler.net/index.php?section=problems&id=59 Problem 59] ==<br />
Using a brute force attack, can you decrypt the cipher using XOR encryption?<br />
<br />
Solution:<br />
<haskell><br />
import Data.Bits<br />
import Data.Char<br />
import Data.List<br />
<br />
keys = [ [a,b,c] | a <- [97..122], b <- [97..122], c <- [97..122] ]<br />
allAlpha a = all (\k -> let a = ord k in (a >= 32 && a <= 122)) a<br />
howManySpaces x = length (elemIndices ' ' x)<br />
compareBy f x y = compare (f x) (f y)<br />
<br />
problem_59 = do<br />
s <- readFile "cipher1.txt"<br />
let <br />
cipher = (read ("[" ++ s ++ "]") :: [Int])<br />
decrypts = [ (map chr (zipWith xor (cycle key) cipher), map chr key) | key <- keys ]<br />
alphaDecrypts = filter (\(x,y) -> allAlpha x) decrypts<br />
message = maximumBy (\(x,y) (x',y') -> compareBy howManySpaces x x') alphaDecrypts<br />
asciisum = sum (map ord (fst message))<br />
putStrLn (show asciisum)<br />
</haskell><br />
<br />
== [http://projecteuler.net/index.php?section=problems&id=60 Problem 60] ==<br />
Find a set of five primes for which any two primes concatenate to produce another prime.<br />
<br />
Solution:<br />
<br />
Breadth first search that works on infinite lists. Breaks the 60 secs rule. This program finds the solution in 185 sec on my Dell D620 Laptop.<br />
<haskell><br />
problem_60 = print$sum $head solve <br />
isPrime x<br />
|x==3=True<br />
|otherwise=millerRabinPrimality x 2 <br />
<br />
solve = do<br />
a <- primesTo10000<br />
let m = f a $ dropWhile (<= a) primesTo10000<br />
b <- m<br />
let n = f b $ dropWhile (<= b) m<br />
c <- n<br />
let o = f c $ dropWhile (<= c) n<br />
d <- o<br />
let p = f d $ dropWhile (<= d) o<br />
e <- p<br />
return [a,b,c,d,e]<br />
where<br />
f x = filter (\y -> all id[isPrime $read $shows x $show y,<br />
isPrime $read $shows y $show x])<br />
primesTo10000 = 2:filter (isPrime) [3,5..9999]<br />
</haskell></div>Scvalexhttps://wiki.haskell.org/index.php?title=Euler_problems/41_to_50&diff=21602Euler problems/41 to 502008-07-04T14:48:30Z<p>Scvalex: </p>
<hr />
<div>== [http://projecteuler.net/index.php?section=problems&id=41 Problem 41] ==<br />
What is the largest n-digit pandigital prime that exists?<br />
<br />
Solution:<br />
<haskell><br />
import Data.List<br />
isprime a = isprimehelper a primes<br />
isprimehelper a (p:ps)<br />
| a == 1 = False<br />
| p*p > a = True<br />
| a `mod` p == 0 = False<br />
| otherwise = isprimehelper a ps<br />
primes = 2 : filter isprime [3,5..]<br />
problem_41 = <br />
head . filter isprime . filter fun $ [7654321,7654320..]<br />
where<br />
fun = (=="1234567") . sort . show<br />
</haskell><br />
<br />
== [http://projecteuler.net/index.php?section=problems&id=42 Problem 42] ==<br />
How many triangle words can you make using the list of common English words?<br />
<br />
Solution:<br />
<haskell><br />
import Data.Char<br />
trilist = takeWhile (<300) (scanl1 (+) [1..])<br />
wordscore xs = sum $ map (subtract 64 . ord) xs<br />
problem_42 megalist = <br />
length [ wordscore a | a <- megalist,<br />
elem (wordscore a) trilist ]<br />
main = do f <- readFile "words.txt"<br />
let words = read $"["++f++"]"<br />
print $ problem_42 words<br />
</haskell><br />
<br />
== [http://projecteuler.net/index.php?section=problems&id=43 Problem 43] ==<br />
Find the sum of all pandigital numbers with an unusual sub-string divisibility property.<br />
<br />
Solution:<br />
<haskell><br />
import Data.List<br />
l2n :: (Integral a) => [a] -> a<br />
l2n = foldl' (\a b -> 10*a+b) 0<br />
<br />
swap (a,b) = (b,a)<br />
<br />
explode :: (Integral a) => a -> [a]<br />
explode = <br />
unfoldr (\a -> if a==0 then Nothing else Just $ swap $ quotRem a 10)<br />
problem_43 = sum . map l2n . map (\s -> head ([0..9] \\ s):s) <br />
. filter (elem 0) . genSeq [] $ [17,13,11,7,5,3,2]<br />
<br />
mults mi ma n = takeWhile (< ma) . dropWhile (<mi) . iterate (+n) $ n<br />
<br />
sequ xs ys = tail xs == init ys<br />
<br />
addZ n xs = replicate (n - length xs) 0 ++ xs<br />
<br />
genSeq [] (x:xs) = genSeq (filter (not . doub) <br />
. map (addZ 3 . reverse . explode)<br />
$ mults 9 1000 x)<br />
xs<br />
genSeq ys (x:xs) = <br />
genSeq (do m <- mults 9 1000 x<br />
let s = addZ 3 . reverse . explode $ m<br />
y <- filter (sequ s . take 3) $ filter (not . elem (head s)) ys<br />
return (head s:y))<br />
xs<br />
genSeq ys [] = ys<br />
<br />
doub xs = nub xs /= xs<br />
</haskell><br />
<br />
== [http://projecteuler.net/index.php?section=problems&id=44 Problem 44] ==<br />
Find the smallest pair of pentagonal numbers whose sum and difference is pentagonal.<br />
<br />
Solution:<br />
<haskell><br />
import Data.Set<br />
problem_44 = head solutions<br />
where solutions = [a-b | a <- penta,<br />
b <- takeWhile (<a) penta,<br />
isPenta (a-b),<br />
isPenta (b+a) ]<br />
isPenta = (`member` fromList penta)<br />
penta = [(n * (3*n-1)) `div` 2 | n <- [1..5000]]<br />
</haskell><br />
<br />
== [http://projecteuler.net/index.php?section=problems&id=45 Problem 45] ==<br />
After 40755, what is the next triangle number that is also pentagonal and hexagonal?<br />
<br />
Solution:<br />
<haskell><br />
isPent n = (af == 0) && ai `mod` 6 == 5<br />
where (ai, af) = properFraction . sqrt $ 1 + 24 * (fromInteger n)<br />
<br />
problem_45 = head [x | x <- scanl (+) 1 [5,9..], x > 40755, isPent x]<br />
</haskell><br />
<br />
== [http://projecteuler.net/index.php?section=problems&id=46 Problem 46] ==<br />
What is the smallest odd composite that cannot be written as the sum of a prime and twice a square?<br />
<br />
Solution:<br />
<br />
This solution is inspired by exercise 3.70 in ''Structure and Interpretation of Computer Programs'', (2nd ed.).<br />
<br />
millerRabinPrimality on the [[Prime_numbers]] page <br />
<br />
<haskell><br />
import Data.List<br />
isPrime x | x==3 = True<br />
| otherwise = millerRabinPrimality x 2<br />
problem_46 = find (\x -> not (isPrime x) && check x) [3,5..]<br />
where <br />
check x = not . any isPrime<br />
. takeWhile (>0)<br />
. map (\y -> x - 2 * y * y) $ [1..]<br />
</haskell><br />
<br />
Alternate Solution:<br />
<br />
Considering that the answer is less than 6000, there's no need for fancy solutions. The following is as fast as most C++ solutions.<br />
<br />
<haskell><br />
primes :: [Int]<br />
primes = 2 : filter isPrime [3, 5..]<br />
<br />
isPrime :: Int -> Bool<br />
isPrime n = all (not . divides n) $ takeWhile (\p -> p^2 <= n) primes<br />
where<br />
divides n p = n `mod` p == 0<br />
<br />
compOdds :: [Int]<br />
compOdds = filter (not . isPrime) [3, 5..]<br />
<br />
verifConj :: Int -> Bool<br />
verifConj n = any isPrime (takeWhile (>0) $ map (\i -> n - 2*i*i) [1..])<br />
<br />
problem_46 :: Int<br />
problem_46 = head $ filter (not . verifConj) compOdds<br />
</haskell><br />
<br />
== [http://projecteuler.net/index.php?section=problems&id=47 Problem 47] ==<br />
Find the first four consecutive integers to have four distinct primes factors.<br />
<br />
Solution:<br />
<haskell><br />
import Data.List<br />
problem_47 = find (all ((==4).snd)) . map (take 4) . tails <br />
. zip [1..] . map (length . factors) $ [1..]<br />
fstfac x = [(head a ,length a) | a <- group $ primeFactors x]<br />
fac [(x,y)] = [x^a | a <- [0..y]]<br />
fac (x:xs) = [a*b | a <- fac [x], b <- fac xs]<br />
factors x = fac $ fstfac x<br />
primes = 2 : filter ((==1) . length . primeFactors) [3,5..]<br />
<br />
primeFactors n = factor n primes<br />
where factor _ [] = []<br />
factor m (p:ps) | p*p > m = [m]<br />
| m `mod` p == 0 = p : [m `div` p]<br />
| otherwise = factor m ps<br />
</haskell><br />
<br />
== [http://projecteuler.net/index.php?section=problems&id=48 Problem 48] ==<br />
Find the last ten digits of 1<sup>1</sup> + 2<sup>2</sup> + ... + 1000<sup>1000</sup>.<br />
<br />
Solution:<br />
If the problem were more computationally intensive, [http://en.wikipedia.org/wiki/Modular_exponentiation modular exponentiation] might be appropriate. With this problem size the naive approach is sufficient.<br />
<br />
powMod on the [[Prime_numbers]] page <br />
<br />
<haskell><br />
problem_48 = flip mod limit $ sum [powMod limit n n | n <- [1..1000]]<br />
where limit=10^10<br />
</haskell><br />
<br />
== [http://projecteuler.net/index.php?section=problems&id=49 Problem 49] ==<br />
Find arithmetic sequences, made of prime terms, whose four digits are permutations of each other.<br />
<br />
Solution:<br />
millerRabinPrimality on the [[Prime_numbers]] page <br />
<br />
<haskell><br />
import Control.Monad<br />
import Data.List<br />
isPrime x<br />
| x==3 = True<br />
| otherwise = millerRabinPrimality x 2<br />
<br />
primes4 = takeWhile (<10000) $ dropWhile (<1000) primes<br />
<br />
problem_49 = do a <- primes4<br />
b <- dropWhile (<= a) primes4<br />
guard (sort $ show a == sort $ show b)<br />
let c = 2 * b - a<br />
guard (c < 10000)<br />
guard (sort $ show a == sort $ show c)<br />
guard $ isPrime c <br />
return (a, b, c)<br />
<br />
primes = 2 : filter (\x -> isPrime x ) [3..]<br />
</haskell><br />
<br />
== [http://projecteuler.net/index.php?section=problems&id=50 Problem 50] ==<br />
Which prime, below one-million, can be written as the sum of the most consecutive primes?<br />
<br />
Solution: <br />
(prime and isPrime not included)<br />
<br />
<haskell><br />
import Control.Monad<br />
findPrimeSum ps <br />
| isPrime sumps = Just sumps<br />
| otherwise = findPrimeSum (tail ps) `mplus` findPrimeSum (init ps)<br />
where<br />
sumps = sum ps<br />
<br />
problem_50 = findPrimeSum $ take 546 primes<br />
</haskell></div>Scvalexhttps://wiki.haskell.org/index.php?title=Euler_problems/41_to_50&diff=21601Euler problems/41 to 502008-07-04T14:42:59Z<p>Scvalex: Added another solution for prob 46</p>
<hr />
<div>== [http://projecteuler.net/index.php?section=problems&id=41 Problem 41] ==<br />
What is the largest n-digit pandigital prime that exists?<br />
<br />
Solution:<br />
<haskell><br />
import Data.List<br />
isprime a = isprimehelper a primes<br />
isprimehelper a (p:ps)<br />
| a == 1 = False<br />
| p*p > a = True<br />
| a `mod` p == 0 = False<br />
| otherwise = isprimehelper a ps<br />
primes = 2 : filter isprime [3,5..]<br />
problem_41 = <br />
head . filter isprime . filter fun $ [7654321,7654320..]<br />
where<br />
fun = (=="1234567") . sort . show<br />
</haskell><br />
<br />
== [http://projecteuler.net/index.php?section=problems&id=42 Problem 42] ==<br />
How many triangle words can you make using the list of common English words?<br />
<br />
Solution:<br />
<haskell><br />
import Data.Char<br />
trilist = takeWhile (<300) (scanl1 (+) [1..])<br />
wordscore xs = sum $ map (subtract 64 . ord) xs<br />
problem_42 megalist = <br />
length [ wordscore a | a <- megalist,<br />
elem (wordscore a) trilist ]<br />
main = do f <- readFile "words.txt"<br />
let words = read $"["++f++"]"<br />
print $ problem_42 words<br />
</haskell><br />
<br />
== [http://projecteuler.net/index.php?section=problems&id=43 Problem 43] ==<br />
Find the sum of all pandigital numbers with an unusual sub-string divisibility property.<br />
<br />
Solution:<br />
<haskell><br />
import Data.List<br />
l2n :: (Integral a) => [a] -> a<br />
l2n = foldl' (\a b -> 10*a+b) 0<br />
<br />
swap (a,b) = (b,a)<br />
<br />
explode :: (Integral a) => a -> [a]<br />
explode = <br />
unfoldr (\a -> if a==0 then Nothing else Just $ swap $ quotRem a 10)<br />
problem_43 = sum . map l2n . map (\s -> head ([0..9] \\ s):s) <br />
. filter (elem 0) . genSeq [] $ [17,13,11,7,5,3,2]<br />
<br />
mults mi ma n = takeWhile (< ma) . dropWhile (<mi) . iterate (+n) $ n<br />
<br />
sequ xs ys = tail xs == init ys<br />
<br />
addZ n xs = replicate (n - length xs) 0 ++ xs<br />
<br />
genSeq [] (x:xs) = genSeq (filter (not . doub) <br />
. map (addZ 3 . reverse . explode)<br />
$ mults 9 1000 x)<br />
xs<br />
genSeq ys (x:xs) = <br />
genSeq (do m <- mults 9 1000 x<br />
let s = addZ 3 . reverse . explode $ m<br />
y <- filter (sequ s . take 3) $ filter (not . elem (head s)) ys<br />
return (head s:y))<br />
xs<br />
genSeq ys [] = ys<br />
<br />
doub xs = nub xs /= xs<br />
</haskell><br />
<br />
== [http://projecteuler.net/index.php?section=problems&id=44 Problem 44] ==<br />
Find the smallest pair of pentagonal numbers whose sum and difference is pentagonal.<br />
<br />
Solution:<br />
<haskell><br />
import Data.Set<br />
problem_44 = head solutions<br />
where solutions = [a-b | a <- penta,<br />
b <- takeWhile (<a) penta,<br />
isPenta (a-b),<br />
isPenta (b+a) ]<br />
isPenta = (`member` fromList penta)<br />
penta = [(n * (3*n-1)) `div` 2 | n <- [1..5000]]<br />
</haskell><br />
<br />
== [http://projecteuler.net/index.php?section=problems&id=45 Problem 45] ==<br />
After 40755, what is the next triangle number that is also pentagonal and hexagonal?<br />
<br />
Solution:<br />
<haskell><br />
isPent n = (af == 0) && ai `mod` 6 == 5<br />
where (ai, af) = properFraction . sqrt $ 1 + 24 * (fromInteger n)<br />
<br />
problem_45 = head [x | x <- scanl (+) 1 [5,9..], x > 40755, isPent x]<br />
</haskell><br />
<br />
== [http://projecteuler.net/index.php?section=problems&id=46 Problem 46] ==<br />
What is the smallest odd composite that cannot be written as the sum of a prime and twice a square?<br />
<br />
Solution:<br />
<br />
This solution is inspired by exercise 3.70 in ''Structure and Interpretation of Computer Programs'', (2nd ed.).<br />
<br />
millerRabinPrimality on the [[Prime_numbers]] page <br />
<br />
<haskell><br />
import Data.List<br />
isPrime x | x==3 = True<br />
| otherwise = millerRabinPrimality x 2<br />
problem_46 = find (\x -> not (isPrime x) && check x) [3,5..]<br />
where <br />
check x = not . any isPrime<br />
. takeWhile (>0)<br />
. map (\y -> x - 2 * y * y) $ [1..]<br />
</haskell><br />
<br />
Alternate Solution:<br />
<br />
Considering that the answer is less than 6000, there's no need for fancy solutions. The following is as fast as most C++ solutions.<br />
<br />
<haskell><br />
primes :: [Int]<br />
primes = 2 : filter isPrime [3, 5..]<br />
<br />
isPrime :: Int -> Bool<br />
isPrime n = all (not . divides n) $ takeWhile (\p -> p^2 <= n) primes<br />
where<br />
divides n p = n `mod` p == 0<br />
<br />
compOdds :: [Int]<br />
compOdds = filter (not . isPrime) [3, 5..]<br />
<br />
verifConj :: Int -> Bool<br />
verifConj n = tryPrime primes<br />
where<br />
tryPrime (p:ps)<br />
| p > n = False<br />
| trySquares p 1 = True<br />
| otherwise = tryPrime ps<br />
trySquares p s<br />
| p + 2*s*s == n = True<br />
| p + 2*s*s > n = False<br />
| otherwise = trySquares p (s+1)<br />
<br />
problem_46 :: Int<br />
problem_46 = head $ filter (not . verifConj) compOdds<br />
<br />
</haskell><br />
<br />
== [http://projecteuler.net/index.php?section=problems&id=47 Problem 47] ==<br />
Find the first four consecutive integers to have four distinct primes factors.<br />
<br />
Solution:<br />
<haskell><br />
import Data.List<br />
problem_47 = find (all ((==4).snd)) . map (take 4) . tails <br />
. zip [1..] . map (length . factors) $ [1..]<br />
fstfac x = [(head a ,length a) | a <- group $ primeFactors x]<br />
fac [(x,y)] = [x^a | a <- [0..y]]<br />
fac (x:xs) = [a*b | a <- fac [x], b <- fac xs]<br />
factors x = fac $ fstfac x<br />
primes = 2 : filter ((==1) . length . primeFactors) [3,5..]<br />
<br />
primeFactors n = factor n primes<br />
where factor _ [] = []<br />
factor m (p:ps) | p*p > m = [m]<br />
| m `mod` p == 0 = p : [m `div` p]<br />
| otherwise = factor m ps<br />
</haskell><br />
<br />
== [http://projecteuler.net/index.php?section=problems&id=48 Problem 48] ==<br />
Find the last ten digits of 1<sup>1</sup> + 2<sup>2</sup> + ... + 1000<sup>1000</sup>.<br />
<br />
Solution:<br />
If the problem were more computationally intensive, [http://en.wikipedia.org/wiki/Modular_exponentiation modular exponentiation] might be appropriate. With this problem size the naive approach is sufficient.<br />
<br />
powMod on the [[Prime_numbers]] page <br />
<br />
<haskell><br />
problem_48 = flip mod limit $ sum [powMod limit n n | n <- [1..1000]]<br />
where limit=10^10<br />
</haskell><br />
<br />
== [http://projecteuler.net/index.php?section=problems&id=49 Problem 49] ==<br />
Find arithmetic sequences, made of prime terms, whose four digits are permutations of each other.<br />
<br />
Solution:<br />
millerRabinPrimality on the [[Prime_numbers]] page <br />
<br />
<haskell><br />
import Control.Monad<br />
import Data.List<br />
isPrime x<br />
| x==3 = True<br />
| otherwise = millerRabinPrimality x 2<br />
<br />
primes4 = takeWhile (<10000) $ dropWhile (<1000) primes<br />
<br />
problem_49 = do a <- primes4<br />
b <- dropWhile (<= a) primes4<br />
guard (sort $ show a == sort $ show b)<br />
let c = 2 * b - a<br />
guard (c < 10000)<br />
guard (sort $ show a == sort $ show c)<br />
guard $ isPrime c <br />
return (a, b, c)<br />
<br />
primes = 2 : filter (\x -> isPrime x ) [3..]<br />
</haskell><br />
<br />
== [http://projecteuler.net/index.php?section=problems&id=50 Problem 50] ==<br />
Which prime, below one-million, can be written as the sum of the most consecutive primes?<br />
<br />
Solution: <br />
(prime and isPrime not included)<br />
<br />
<haskell><br />
import Control.Monad<br />
findPrimeSum ps <br />
| isPrime sumps = Just sumps<br />
| otherwise = findPrimeSum (tail ps) `mplus` findPrimeSum (init ps)<br />
where<br />
sumps = sum ps<br />
<br />
problem_50 = findPrimeSum $ take 546 primes<br />
</haskell></div>Scvalexhttps://wiki.haskell.org/index.php?title=Blog_articles/Network&diff=21351Blog articles/Network2008-06-17T17:29:10Z<p>Scvalex: Blog entry was gone</p>
<hr />
<div>== Network ==<br />
<br />
=== HTTP ===<br />
<br />
* [http://nominolo.blogspot.com/2007/05/networkhttp-bytestrings.html Network.HTTP + ByteStrings]<br />
* [http://www.alpheccar.org/en/posts/show/73 Haskell: Preventing irreversible updates from HTTP GET with types]<br />
* [http://scsibug.com/2007/09/23/haskell-s3-library/ Amazon S3 binding]<br />
<br />
=== TCP ===<br />
<br />
* [http://sequence.complete.org/node/258 Simple STM TCP server]<br />
* [http://stephan.walter.name/blog/computers/programming/haskell/interacttcp.html Haskell's 'interact' with TCP sockets]<br />
* [http://blog.moertel.com/articles/2004/03/13/concurrent-port-scanner-in-haskell Concurrent Port Scanner in Haskell]<br />
* Simple socket programming:<br />
** [http://metavar.blogspot.com/2007/03/simple-socket-programming.html Part 1]<br />
** [http://metavar.blogspot.com/2007/03/simple-socket-programming-2-revenge-of.html Part 2]<br />
* [http://austin.youareinferior.net/?q=node/24 On haskell: writing a packet sniffer]<br />
* [http://abstractabsurd.blogspot.com/2007/05/couple-of-silly-examples.html A simple echo server]<br />
* [http://emilliken.blogspot.com/2007/07/haskell-datapipe.html A concurrent networked data pipe]<br />
<br />
=== Ethernet ===<br />
<br />
* [http://emilliken.blogspot.com/2007/07/using-haskell-for-reading-raw-ethernet.html Using haskell for reading raw ethernet frames]<br />
<br />
=== IRC ===<br />
<br />
* [http://blog.nurd.se/hype/?p=30 An IRC client/server in Haskell]<br />
* [http://haskell.org/haskellwiki/Roll_your_own_IRC_bot Roll your own Haskell IRC bot]<br />
<br />
== Further reading ==<br />
<br />
* [http://hackage.haskell.org/packages/archive/pkg-list.html#cat:Network Network libraries on Hackage]</div>Scvalexhttps://wiki.haskell.org/index.php?title=99_questions/31_to_41&diff=2067799 questions/31 to 412008-04-24T12:27:04Z<p>Scvalex: added a more concise solution for problem 32</p>
<hr />
<div>__NOTOC__<br />
<br />
This is part of [[H-99:_Ninety-Nine_Haskell_Problems|Ninety-Nine Haskell Problems]], based on [https://prof.ti.bfh.ch/hew1/informatik3/prolog/p-99/ Ninety-Nine Prolog Problems].<br />
<br />
== Arithmetic ==<br />
<br />
== Problem 31 ==<br />
<br />
(**) Determine whether a given integer number is prime.<br />
<br />
Example:<br />
<pre><br />
* (is-prime 7)<br />
T<br />
</pre><br />
Example in Haskell:<br />
<pre><br />
P31> isPrime 7<br />
True<br />
</pre><br />
<br />
Solution:<br />
<haskell><br />
isPrime :: Integral a => a -> Bool<br />
isPrime p = p > 1 && all (\n -> p `mod` n /= 0 ) $ takeWhile (\n -> n*n <= p) [2..] <br />
</haskell><br />
<br />
Well, a natural number p is a prime number iff it is larger than 1 and no natural number n with n >= 2 and n^2 <= p is a divisor of p. That's exactly what is implemented: we take the list of all integral numbers starting with 2 as long as their square is at most p and check that for all these n there is a remainder concerning the division of p by n.<br />
<br />
== Problem 32 ==<br />
<br />
(**) Determine the greatest common divisor of two positive integer numbers.<br />
Use Euclid's algorithm.<br />
<br />
<pre><br />
Example:<br />
* (gcd 36 63)<br />
9<br />
<br />
Example in Haskell:<br />
[myGCD 36 63, myGCD (-3) (-6), myGCD (-3) 6]<br />
[9,3,3]<br />
</pre><br />
<br />
Solution:<br />
<haskell><br />
gcd' 0 y = y<br />
gcd' x y = gcd' (y `mod` x) x<br />
myGCD x y | x < 0 = myGCD (-x) y<br />
| y < 0 = myGCD x (-y)<br />
| y < x = gcd' y x<br />
| otherwise = gcd' x y<br />
</haskell><br />
<br />
The Prelude includes a gcd function, so we have to choose another name for ours. The function gcd' is a straightforward implementation of Euler's algorithm, and myGCD is just a wrapper that makes sure the arguments are positive and in increasing order.<br />
<br />
A more concise implementation is:<br />
<haskell><br />
myGCD :: Integer -> Integer -> Integer<br />
myGCD a b<br />
| b == 0 = abs a<br />
| otherwise = myGCD b (a `mod` b)<br />
</haskell><br />
<br />
== Problem 33 ==<br />
<br />
(*) Determine whether two positive integer numbers are coprime.<br />
Two numbers are coprime if their greatest common divisor equals 1.<br />
<br />
Example:<br />
<pre><br />
* (coprime 35 64)<br />
T<br />
</pre><br />
<br />
Example in Haskell:<br />
<pre><br />
* coprime 35 64<br />
True <br />
</pre><br />
<br />
Solution:<br />
<haskell><br />
coprime a b = gcd a b == 1<br />
</haskell><br />
<br />
Here we use the prelude function for computing gcd's along with a test of the result's equality to one. <br />
<br />
== Problem 34 ==<br />
<br />
(**) Calculate Euler's totient function phi(m).<br />
Euler's so-called totient function phi(m) is defined as the number of positive integers r (1 <= r < m) that are coprime to m.<br />
Example: m = 10: r = 1,3,7,9; thus phi(m) = 4. Note the special case: phi(1) = 1.<br />
<pre><br />
Example:<br />
* (totient-phi 10)<br />
4<br />
Example in Haskell:<br />
* totient 10<br />
4<br />
</pre><br />
<br />
Solution:<br />
<haskell><br />
totient 1 = 1<br />
totient a = length $ filter (coprime a) [1..a-1]<br />
where coprime a b = gcd a b == 1<br />
</haskell><br />
<br />
We take coprime from the previous exercise and give it to filter, which applies it to each element of a list from 1 to one less than the number, returning only those that are true. length tells us how many elements are in the resulting list, and thus how many elements are coprime to n<br />
<br />
== Problem 35 ==<br />
<br />
(**) Determine the prime factors of a given positive integer.<br />
Construct a flat list containing the prime factors in ascending order.<br />
<br />
Example:<br />
<pre><br />
* (prime-factors 315)<br />
(3 3 5 7)<br />
</pre><br />
Example in Haskell:<br />
<pre><br />
> primeFactors 315<br />
[3, 3, 5, 7]<br />
</pre><br />
<br />
Solution:<br />
<haskell><br />
primeFactors :: Integer -> [Integer]<br />
primeFactors a = let (f, f1) = factorPairOf a<br />
f' = if prime f then [f] else primeFactors f<br />
f1' = if prime f1 then [f1] else primeFactors f1<br />
in f' ++ f1'<br />
where<br />
factorPairOf a = let f = head $ factors a<br />
in (f, div a f)<br />
factors a = filter (isFactor a) [2..a-1]<br />
isFactor a b = rem a b == 0<br />
prime a = (length $ factors a) == 0<br />
</haskell><br />
<br />
Kind of ugly, but it works, though it may have bugs in corner cases. This uses the factor tree method of finding prime factors of a number. factorPairOf picks a factor and takes it and the factor you multiply it by and gives them to primeFactors. primeFactors checks to make sure the factors are prime. If not it prime factorizes them. In the end a list of prime factors is returned.<br />
<br />
Another possibility is to observe that you need not ensure that potential divisors are primes, as long as you consider them in ascending order:<br />
<haskell><br />
primeFactors n = primeFactors' n 2 where<br />
primeFactors' 1 _ = []<br />
primeFactors' n factor<br />
| n `mod` factor == 0 = factor : primeFactors' (n `div` factor) factor<br />
| otherwise = primeFactors' n (factor + 1)<br />
</haskell><br />
Thus, we just loop through all possible factors and add them to the list if they divide the original number. As the primes get farther apart, though, this will do a lot of needless checks to see if composite numbers are prime factors.<br />
However we can stop as soon as the candidate factor exceeds the square root of n:<br />
<haskell><br />
primeFactors n = primeFactors' n 2 where<br />
primeFactors' n factor<br />
| factor*factor > n = [n]<br />
| n `mod` factor == 0 = factor : primeFactors' (n `div` factor) factor<br />
| otherwise = primeFactors' n (factor + 1)<br />
</haskell><br />
<br />
You can avoid the needless work by just looping through the primes:<br />
<haskell><br />
primeFactors n = factor n primes<br />
where factor n (p:ps) | p*p > n = [n]<br />
| n `mod` p /= 0 = factor n ps<br />
| otherwise = p : factor (n `div` p) (p:ps)<br />
primes = 2 : filter ((==1) . length . primeFactors) [3,5..]<br />
</haskell><br />
(see also discussion of this solution following "Discuss this page")<br />
<br />
== Problem 36 ==<br />
(**) Determine the prime factors of a given positive integer.<br />
<br />
Construct a list containing the prime factors and their multiplicity.<br />
<br />
Example:<br />
<pre><br />
* (prime-factors-mult 315)<br />
((3 2) (5 1) (7 1))<br />
</pre><br />
Example in Haskell:<br />
<pre><br />
*Main> prime_factors_mult 315<br />
[(3,2),(5,1),(7,1)]<br />
</pre><br />
<br />
Solution:<br />
<haskell><br />
prime_factors_mult n = map swap $ encode $ primeFactors n<br />
where swap (x,y) = (y,x)<br />
</haskell><br />
using <tt>primeFactors</tt> from problem 35 to generate the list of prime factors in ascending order, and <tt>encode</tt> from problem 10 to compress this list to a list of numbers paired with their multiplicity.<br />
<br />
== Problem 37 ==<br />
<br />
(**) Calculate Euler's totient function phi(m) (improved).<br />
See problem 34 for the definition of Euler's totient function. If the list of the prime factors of a number m is known in the form of problem 36 then the function phi(m) can be efficiently calculated as follows: Let ((p1 m1) (p2 m2) (p3 m3) ...) be the list of prime factors (and their multiplicities) of a given number m. Then phi(m) can be calculated with the following formula:<br />
<br />
<pre><br />
phi(m) = (p1 - 1) * p1 ** (m1 - 1) + (p2 - 1) * p2 ** (m2 - 1) + (p3 - 1) * p3 ** (m3 - 1) + ...<br />
</pre><br />
<br />
Note that a ** b stands for the b'th power of a.<br />
<i>Note</i>: Actually, the official problems show this as a sum, but it should be a product.<br />
<br />
Solution: Given prime_factors_mult from problem 36, we get<br />
<haskell><br />
totient m = product [(p - 1) * p ^ (c - 1) | (p, c) <- prime_factors_mult m]<br />
</haskell><br />
This just uses a list comprehension to build each term of the product in the formula for phi, then multiplies them all.<br />
<br />
== Problem 38 ==<br />
<br />
(*) Compare the two methods of calculating Euler's totient function.<br />
<br />
Use the solutions of problems 34 and 37 to compare the algorithms. Take the number of reductions as a measure for efficiency. Try to calculate phi(10090) as an example.<br />
<br />
(no solution required)<br />
<br />
== Problem 39 ==<br />
<br />
(*) A list of prime numbers.<br />
<br />
Given a range of integers by its lower and upper limit, construct a list of all prime numbers in that range.<br />
<br />
<pre><br />
Example in Haskell:<br />
P29> primesR 10 20<br />
[11,13,17,19]<br />
</pre><br />
<br />
Solution 1:<br />
<haskell><br />
primesR :: Integral a => a -> a -> [a]<br />
primesR a b = filter isPrime [a..b]<br />
</haskell><br />
<br />
If we are challenged to give all primes in the range between a and b we simply take all number from a up to b and filter the primes out.<br />
<br />
Solution 2:<br />
<haskell><br />
primes :: Integral a => [a]<br />
primes = let sieve (n:ns) = n:sieve [ m | m <- ns, m `mod` n /= 0 ] in sieve [2..]<br />
<br />
primesR :: Integral a => a -> a -> [a]<br />
primesR a b = takeWhile (<= b) $ dropWhile (< a) primes<br />
</haskell><br />
<br />
Another way to compute the claimed list is done by using the ''Sieve of Eratosthenes''. The <hask>primes</hask> function generates a list of all (!) prime numbers using this algorithm and <hask>primesR</hask> filter the relevant range out. [But this way is very slow and I only presented it because I wanted to show how nice the ''Sieve of Eratosthenes'' can be implemented in Haskell :)]<br />
<br />
== Problem 40 ==<br />
(**) Goldbach's conjecture.<br />
Goldbach's conjecture says that every positive even number greater than 2 is the sum of two prime numbers. Example: 28 = 5 + 23. It is one of the most famous facts in number theory that has not been proved to be correct in the general case. It has been numerically confirmed up to very large numbers (much larger than we can go with our Prolog system). Write a predicate to find the two prime numbers that sum up to a given even integer.<br />
<br />
<pre><br />
Example:<br />
* (goldbach 28)<br />
(5 23)<br />
<br />
Example in Haskell:<br />
*goldbach 28<br />
(5, 23)<br />
</pre><br />
<br />
Solution 1:<br />
<haskell><br />
goldbach a = head $<br />
filter (\e -> (isPrime $ fst e) && (isPrime $ snd e)) $<br />
map (\e -> (e, a - e)) [1,3..div a 2]<br />
where<br />
factors a = filter (isFactor a) [2..a-1]<br />
isFactor a b = rem a b == 0<br />
isPrime a = (length $ factors a) == 0<br />
</haskell><br />
<br />
Woohoo! I've solved the goldbach conjecture! Where do I collect my prize? This does the obvious thing. It makes a list of odd numbers and then uses it to make up pairs of odd numbers that sum to n. Then it looks for a pair of odd numbers where both are prime and returns it as a tuple.<br />
<br />
Solution 2:<br />
<haskell><br />
-- using the previous problem...<br />
goldbach n = head [(x,y) | x <- pr, y <- pr, x+y==n]<br />
where pr = takeWhile (< n) primes<br />
</haskell><br />
<br />
Solution 3:<br />
<haskell><br />
goldbach n = head [(x,y) | x <- takeWhile (< n) primes, let y = n-x, isPrime y]<br />
</haskell><br />
<br />
== Problem 41 ==<br />
<br />
(**) Given a range of integers by its lower and upper limit, print a list of all even numbers and their Goldbach composition.<br />
<br />
In most cases, if an even number is written as the sum of two prime numbers, one of them is very small. Very rarely, the primes are both bigger than say 50. Try to find out how many such cases there are in the range 2..3000.<br />
<br />
Example:<br />
<pre><br />
* (goldbach-list 9 20)<br />
10 = 3 + 7<br />
12 = 5 + 7<br />
14 = 3 + 11<br />
16 = 3 + 13<br />
18 = 5 + 13<br />
20 = 3 + 17<br />
* (goldbach-list 1 2000 50)<br />
992 = 73 + 919<br />
1382 = 61 + 1321<br />
1856 = 67 + 1789<br />
1928 = 61 + 1867<br />
</pre><br />
<br />
Example in Haskell:<br />
<pre><br />
*Exercises> goldbachList 9 20<br />
[(3,7),(5,7),(3,11),(3,13),(5,13),(3,17)]<br />
*Exercises> goldbachList' 4 2000 50<br />
[(73,919),(61,1321),(67,1789),(61,1867)]<br />
</pre><br />
<br />
Solution:<br />
<haskell><br />
goldbachList lb ub = map goldbach $ [even_lb,even_lb+2..ub]<br />
where even_lb = max ((lb+1) `div` 2 * 2) 4<br />
goldbachList' lb ub mv = filter (\(a,b) -> a > mv && b > mv) $<br />
goldbachList lb ub<br />
</haskell><br />
using the <tt>goldbach</tt> function from problem 40.<br />
<br />
[[Category:Tutorials]]</div>Scvalexhttps://wiki.haskell.org/index.php?title=99_questions/11_to_20&diff=2067599 questions/11 to 202008-04-24T10:09:20Z<p>Scvalex: added one more solution to problem 17</p>
<hr />
<div>__NOTOC__<br />
<br />
This is part of [[H-99:_Ninety-Nine_Haskell_Problems|Ninety-Nine Haskell Problems]], based on [https://prof.ti.bfh.ch/hew1/informatik3/prolog/p-99/ Ninety-Nine Prolog Problems] and [http://www.ic.unicamp.br/~meidanis/courses/mc336/2006s2/funcional/L-99_Ninety-Nine_Lisp_Problems.html Ninety-Nine Lisp Problems].<br />
<br />
== Problem 11 ==<br />
<br />
(*) Modified run-length encoding. <br />
Modify the result of problem 10 in such a way that if an element has no duplicates it is simply copied into the result list. Only elements with duplicates are transferred as (N E) lists.<br />
<br />
<pre><br />
Example:<br />
* (encode-modified '(a a a a b c c a a d e e e e))<br />
((4 A) B (2 C) (2 A) D (4 E))<br />
<br />
Example in Haskell:<br />
P11> encodeModified "aaaabccaadeeee"<br />
[Multiple 4 'a',Single 'b',Multiple 2 'c',Multiple 2 'a',Single 'd',Multiple 4 'e']<br />
</pre><br />
<br />
Solution:<br />
<haskell><br />
data ListItem a = Single a | Multiple Int a<br />
deriving (Show)<br />
<br />
encodeModified :: Eq a => [a] -> [ListItem a]<br />
encodeModified = map encodeHelper . encode<br />
where<br />
encodeHelper (1,x) = Single x<br />
encodeHelper (n,x) = Multiple n x<br />
</haskell><br />
<br />
Again, like in problem 7, we need a utility type because lists in haskell are homogeneous. Afterwards we use the <hask>encode</hask> function from problem 10 and map single instances of a list item to <hask>Single</hask> and multiple ones to <hask>Multiple</hask>.<br />
<br />
The ListItem definition contains 'deriving (Show)' so that we can get interactive output.<br />
<br />
== Problem 12 ==<br />
<br />
(**) Decode a run-length encoded list. <br />
Given a run-length code list generated as specified in problem 11. Construct its uncompressed version.<br />
<br />
<pre><br />
Example in Haskell:<br />
P12> decodeModified [Multiple 4 'a',Single 'b',Multiple 2 'c',Multiple 2 'a',Single 'd',Multiple 4 'e']<br />
"aaaabccaadeeee"<br />
</pre><br />
<br />
Solution:<br />
<haskell><br />
decodeModified :: [ListItem a] -> [a]<br />
decodeModified = concatMap decodeHelper<br />
where<br />
decodeHelper (Single x) = [x]<br />
decodeHelper (Multiple n x) = replicate n x<br />
</haskell><br />
<br />
We only need to map single instances of an element to a list containing only one element and multiple ones to a list containing the specified number of elements and concatenate these lists.<br />
<br />
== Problem 13 ==<br />
<br />
(**) Run-length encoding of a list (direct solution). <br />
Implement the so-called run-length encoding data compression method directly. I.e. don't explicitly create the sublists containing the duplicates, as in problem 9, but only count them. As in problem P11, simplify the result list by replacing the singleton lists (1 X) by X.<br />
<br />
<pre><br />
Example:<br />
* (encode-direct '(a a a a b c c a a d e e e e))<br />
((4 A) B (2 C) (2 A) D (4 E))<br />
<br />
Example in Haskell:<br />
P13> encodeDirect "aaaabccaadeeee"<br />
[Multiple 4 'a',Single 'b',Multiple 2 'c',Multiple 2 'a',Single 'd',Multiple 4 'e']<br />
</pre><br />
<br />
Solution:<br />
<haskell><br />
encode' :: Eq a => [a] -> [(Int,a)]<br />
encode' = foldr helper []<br />
where<br />
helper x [] = [(1,x)]<br />
helper x (y:ys)<br />
| x == snd y = (1+fst y,x):ys<br />
| otherwise = (1,x):y:ys<br />
<br />
encodeDirect :: Eq a => [a] -> [ListItem a]<br />
encodeDirect = map encodeHelper . encode'<br />
where<br />
encodeHelper (1,x) = Single x<br />
encodeHelper (n,x) = Multiple n x<br />
</haskell><br />
<br />
First of all we could rewrite the function <hask>encode</hask> from problem 10 in a way that is does not create the sublists. Thus, I decided to traverse the original list from right to left (using <hask>foldr</hask>) and to prepend each element to the resulting list in the proper way. Thereafter we only need to modify the function <hask>encodeModified</hask> from problem 11 to use <hask>encode'</hask>.<br />
<br />
== Problem 14 ==<br />
<br />
(*) Duplicate the elements of a list.<br />
<br />
<pre><br />
Example:<br />
* (dupli '(a b c c d))<br />
(A A B B C C C C D D)<br />
<br />
Example in Haskell:<br />
> dupli [1, 2, 3]<br />
[1,1,2,2,3,3]<br />
</pre><br />
<br />
Solution:<br />
<haskell><br />
dupli [] = []<br />
dupli (x:xs) = x:x:dupli xs<br />
</haskell><br />
<br />
or, using list comprehension syntax:<br />
<br />
<haskell><br />
dupli list = concat [[x,x] | x <- list]<br />
</haskell><br />
<br />
or, using the list monad:<br />
<haskell><br />
dupli xs = xs >>= (\x -> [x,x])<br />
</haskell><br />
<br />
or, using concatMap:<br />
<haskell><br />
dupli = concatMap (\x -> [x,x])<br />
</haskell><br />
<br />
or, using foldr:<br />
<haskell><br />
dupli = foldr (\ x xs -> x : x : xs) []<br />
</haskell><br />
<br />
== Problem 15 ==<br />
<br />
(**) Replicate the elements of a list a given number of times.<br />
<br />
<pre><br />
Example:<br />
* (repli '(a b c) 3)<br />
(A A A B B B C C C)<br />
<br />
Example in Haskell:<br />
> repli "abc" 3<br />
"aaabbbccc"<br />
</pre><br />
<br />
Solution:<br />
<haskell><br />
repli :: [a] -> Int -> [a]<br />
repli xs n = concatMap (replicate n) xs<br />
</haskell><br />
<br />
== Problem 16 ==<br />
(**) Drop every N'th element from a list.<br />
<br />
<pre><br />
Example:<br />
* (drop '(a b c d e f g h i k) 3)<br />
(A B D E G H K)<br />
<br />
Example in Haskell:<br />
*Main> dropEvery "abcdefghik" 3<br />
"abdeghk"<br />
</pre><br />
<br />
An iterative solution:<br />
<haskell><br />
dropEvery :: [a] -> Int -> [a]<br />
dropEvery [] _ = []<br />
dropEvery (x:xs) n = dropEvery' (x:xs) n 1 where<br />
dropEvery' (x:xs) n i = (if (n `divides` i) then<br />
[] else<br />
[x])<br />
++ (dropEvery' xs n (i+1))<br />
dropEvery' [] _ _ = []<br />
divides x y = y `mod` x == 0<br />
</haskell><br />
<br />
or an alternative iterative solution:<br />
<haskell><br />
dropEvery :: [a] -> Int -> [a]<br />
dropEvery list count = helper list count count<br />
where helper [] _ _ = []<br />
helper (x:xs) count 1 = helper xs count count<br />
helper (x:xs) count n = x : (helper xs count (n - 1))<br />
</haskell><br />
<br />
or using zip:<br />
<haskell><br />
dropEvery n = map snd . filter ((n/=) . fst) . zip (cycle [1..n])<br />
</haskell><br />
<br />
== Problem 17 ==<br />
<br />
(*) Split a list into two parts; the length of the first part is given.<br />
<br />
Do not use any predefined predicates.<br />
<br />
<pre><br />
Example:<br />
* (split '(a b c d e f g h i k) 3)<br />
( (A B C) (D E F G H I K))<br />
<br />
Example in Haskell:<br />
*Main> split "abcdefghik" 3<br />
("abc", "defghik")<br />
</pre><br />
<br />
Solution using take and drop:<br />
<haskell><br />
split xs n = (take n xs, drop n xs)<br />
</haskell><br />
<br />
Alternatively, we have the following recursive solution:<br />
<haskell><br />
split :: [a] -> Int -> ([a], [a])<br />
split [] _ = ([], [])<br />
split l@(x : xs) n | n > 0 = (x : fst splitSub, snd splitSub)<br />
| otherwise = ([], l)<br />
where splitSub = split xs (n - 1)<br />
</haskell><br />
<br />
The same solution as above written more cleanly:<br />
<haskell><br />
split :: [a] -> Int -> ([a], [a])<br />
split xs 0 = ([], xs)<br />
split (x:xs) n = let (f,l) = split xs (n-1) in (x : f, l)<br />
</haskell><br />
<br />
Note that this function, with the parameters in the other order, exists as <hask>splitAt</hask>.<br />
<br />
<br />
== Problem 18 ==<br />
<br />
(**) Extract a slice from a list.<br />
<br />
Given two indices, i and k, the slice is the list containing the elements between the i'th and k'th element of the original list (both limits included). Start counting the elements with 1.<br />
<br />
<pre><br />
Example:<br />
* (slice '(a b c d e f g h i k) 3 7)<br />
(C D E F G)<br />
<br />
Example in Haskell:<br />
*Main> slice ['a','b','c','d','e','f','g','h','i','k'] 3 7<br />
"cdefg"<br />
</pre><br />
<br />
Solution:<br />
<haskell><br />
slice xs (i+1) k = take (k-i) $ drop i xs<br />
</haskell><br />
<br />
== Problem 19 ==<br />
<br />
(**) Rotate a list N places to the left.<br />
<br />
Hint: Use the predefined functions length and (++).<br />
<br />
<pre><br />
Examples:<br />
* (rotate '(a b c d e f g h) 3)<br />
(D E F G H A B C)<br />
<br />
* (rotate '(a b c d e f g h) -2)<br />
(G H A B C D E F)<br />
<br />
Examples in Haskell:<br />
*Main> rotate ['a','b','c','d','e','f','g','h'] 3<br />
"defghabc"<br />
<br />
*Main> rotate ['a','b','c','d','e','f','g','h'] (-2)<br />
"ghabcdef"<br />
</pre><br />
<br />
Solution:<br />
<haskell><br />
rotate [] _ = []<br />
rotate l 0 = l<br />
rotate (x:xs) (n+1) = rotate (xs ++ [x]) n<br />
rotate l n = rotate l (length l + n)<br />
</haskell><br />
<br />
There are two separate cases:<br />
* If n > 0, move the first element to the end of the list n times.<br />
* If n < 0, convert the problem to the equivalent problem for n > 0 by adding the list's length to n.<br />
<br />
or using cycle:<br />
<haskell><br />
rotate xs n = take len . drop (n `mod` len) . cycle $ xs<br />
where len = length xs<br />
</haskell><br />
<br />
or<br />
<br />
<haskell><br />
rotate xs n = if n >= 0 then<br />
drop n xs ++ take n xs<br />
else let l = ((length xs) + n) in<br />
drop l xs ++ take l xs<br />
</haskell><br />
<br />
or<br />
<br />
<haskell><br />
rotate xs n = drop nn xs ++ take nn xs<br />
where <br />
nn = n `mod` length xs<br />
</haskell><br />
<br />
== Problem 20 ==<br />
<br />
(*) Remove the K'th element from a list.<br />
<br />
Example in Prolog:<br />
<pre><br />
?- remove_at(X,[a,b,c,d],2,R).<br />
X = b<br />
R = [a,c,d]<br />
</pre><br />
<br />
Example in Lisp:<br />
<pre><br />
* (remove-at '(a b c d) 2)<br />
(A C D)<br />
</pre><br />
(Note that this only returns the residue list, while the Prolog version also returns the deleted element.)<br />
<br />
Example in Haskell:<br />
<pre><br />
*Main> removeAt 1 "abcd"<br />
('b',"acd")<br />
</pre><br />
<br />
Solution:<br />
<haskell><br />
removeAt :: Int -> [a] -> (a, [a])<br />
removeAt k xs = case back of<br />
[] -> error "removeAt: index too large"<br />
x:rest -> (x, front ++ rest)<br />
where (front, back) = splitAt k xs<br />
</haskell><br />
<br />
Simply use the <hask>splitAt</hask> to split after k elements.<br />
If the original list has fewer than k+1 elements, the second list will be empty, and there will be no element to extract.<br />
Note that the Prolog and Lisp versions treat 1 as the first element in the list, and the Lisp version appends NIL elements to the end of the list if k is greater than the list length.<br />
<br />
or <br />
<br />
<haskell><br />
removeAt n xs = (xs!!n,take n xs ++ drop (n+1) xs)<br />
</haskell><br />
<br />
[[Category:Tutorials]]</div>Scvalexhttps://wiki.haskell.org/index.php?title=Talk:99_questions/11_to_20&diff=20674Talk:99 questions/11 to 202008-04-24T09:51:45Z<p>Scvalex: suggest modifying problem 15</p>
<hr />
<div>The prototype for repli in problem 15 is<br />
<haskell><br />
repli :: [a] -> Int -> [a]<br />
</haskell><br />
<br />
Because the second parameter is the number of times to replicate, it discourages the use function composition. I mean that if you swapped the parameters you could write it pointfree:<br />
<haskell><br />
repli :: Int -> [a] -> [a]<br />
repli n = foldr (\ x xs -> replicate n x ++ xs) []<br />
</haskell><br />
<br />
This would also match the way replicate is defined:<br />
<haskell><br />
replicate :: Int -> a -> [a]<br />
</haskell><br />
<br />
So, I suggest modifying problem 15 by swapping the parameters to repli in the example and the solution.<br />
<br />
----<br />
<br />
I made an edit to this page. I removed the following solution to problem 18:<br />
<br />
<haskell><br />
slice xs i j = [xs!!(i-1)..xs!!(j-1)]<br />
</haskell><br />
<br />
Counter-example:<br />
<haskell><br />
slice [1,3,6,3,1,6,7,8,3,2,4,76,8] 4 5 == []<br />
<br />
Thanks to pixel for pointing this out.</haskell><br />
<br />
----<br />
<br />
The solution to problem 20 seems to be using 0-based indexing, whereas the question called for 1-based indexing in the other languages. This can be easily fixed:<br />
<br />
<haskell><br />
removeAt :: Int -> [a] -> (a, [a])<br />
removeAt k l = (elementAt l k, take (k-1) l ++ drop k l)</haskell><br />
using elementAt from a previous problem.<br />
<br />
<br />
or if you want to express that 1-based indexing is silly,<br />
<haskell><br />
removeAt n+1 xs = (xs!!n,take n xs ++ drop (n+1) xs)</haskell></div>Scvalexhttps://wiki.haskell.org/index.php?title=99_questions/11_to_20&diff=2067399 questions/11 to 202008-04-24T09:36:38Z<p>Scvalex: added foldr solution to problem 14</p>
<hr />
<div>__NOTOC__<br />
<br />
This is part of [[H-99:_Ninety-Nine_Haskell_Problems|Ninety-Nine Haskell Problems]], based on [https://prof.ti.bfh.ch/hew1/informatik3/prolog/p-99/ Ninety-Nine Prolog Problems] and [http://www.ic.unicamp.br/~meidanis/courses/mc336/2006s2/funcional/L-99_Ninety-Nine_Lisp_Problems.html Ninety-Nine Lisp Problems].<br />
<br />
== Problem 11 ==<br />
<br />
(*) Modified run-length encoding. <br />
Modify the result of problem 10 in such a way that if an element has no duplicates it is simply copied into the result list. Only elements with duplicates are transferred as (N E) lists.<br />
<br />
<pre><br />
Example:<br />
* (encode-modified '(a a a a b c c a a d e e e e))<br />
((4 A) B (2 C) (2 A) D (4 E))<br />
<br />
Example in Haskell:<br />
P11> encodeModified "aaaabccaadeeee"<br />
[Multiple 4 'a',Single 'b',Multiple 2 'c',Multiple 2 'a',Single 'd',Multiple 4 'e']<br />
</pre><br />
<br />
Solution:<br />
<haskell><br />
data ListItem a = Single a | Multiple Int a<br />
deriving (Show)<br />
<br />
encodeModified :: Eq a => [a] -> [ListItem a]<br />
encodeModified = map encodeHelper . encode<br />
where<br />
encodeHelper (1,x) = Single x<br />
encodeHelper (n,x) = Multiple n x<br />
</haskell><br />
<br />
Again, like in problem 7, we need a utility type because lists in haskell are homogeneous. Afterwards we use the <hask>encode</hask> function from problem 10 and map single instances of a list item to <hask>Single</hask> and multiple ones to <hask>Multiple</hask>.<br />
<br />
The ListItem definition contains 'deriving (Show)' so that we can get interactive output.<br />
<br />
== Problem 12 ==<br />
<br />
(**) Decode a run-length encoded list. <br />
Given a run-length code list generated as specified in problem 11. Construct its uncompressed version.<br />
<br />
<pre><br />
Example in Haskell:<br />
P12> decodeModified [Multiple 4 'a',Single 'b',Multiple 2 'c',Multiple 2 'a',Single 'd',Multiple 4 'e']<br />
"aaaabccaadeeee"<br />
</pre><br />
<br />
Solution:<br />
<haskell><br />
decodeModified :: [ListItem a] -> [a]<br />
decodeModified = concatMap decodeHelper<br />
where<br />
decodeHelper (Single x) = [x]<br />
decodeHelper (Multiple n x) = replicate n x<br />
</haskell><br />
<br />
We only need to map single instances of an element to a list containing only one element and multiple ones to a list containing the specified number of elements and concatenate these lists.<br />
<br />
== Problem 13 ==<br />
<br />
(**) Run-length encoding of a list (direct solution). <br />
Implement the so-called run-length encoding data compression method directly. I.e. don't explicitly create the sublists containing the duplicates, as in problem 9, but only count them. As in problem P11, simplify the result list by replacing the singleton lists (1 X) by X.<br />
<br />
<pre><br />
Example:<br />
* (encode-direct '(a a a a b c c a a d e e e e))<br />
((4 A) B (2 C) (2 A) D (4 E))<br />
<br />
Example in Haskell:<br />
P13> encodeDirect "aaaabccaadeeee"<br />
[Multiple 4 'a',Single 'b',Multiple 2 'c',Multiple 2 'a',Single 'd',Multiple 4 'e']<br />
</pre><br />
<br />
Solution:<br />
<haskell><br />
encode' :: Eq a => [a] -> [(Int,a)]<br />
encode' = foldr helper []<br />
where<br />
helper x [] = [(1,x)]<br />
helper x (y:ys)<br />
| x == snd y = (1+fst y,x):ys<br />
| otherwise = (1,x):y:ys<br />
<br />
encodeDirect :: Eq a => [a] -> [ListItem a]<br />
encodeDirect = map encodeHelper . encode'<br />
where<br />
encodeHelper (1,x) = Single x<br />
encodeHelper (n,x) = Multiple n x<br />
</haskell><br />
<br />
First of all we could rewrite the function <hask>encode</hask> from problem 10 in a way that is does not create the sublists. Thus, I decided to traverse the original list from right to left (using <hask>foldr</hask>) and to prepend each element to the resulting list in the proper way. Thereafter we only need to modify the function <hask>encodeModified</hask> from problem 11 to use <hask>encode'</hask>.<br />
<br />
== Problem 14 ==<br />
<br />
(*) Duplicate the elements of a list.<br />
<br />
<pre><br />
Example:<br />
* (dupli '(a b c c d))<br />
(A A B B C C C C D D)<br />
<br />
Example in Haskell:<br />
> dupli [1, 2, 3]<br />
[1,1,2,2,3,3]<br />
</pre><br />
<br />
Solution:<br />
<haskell><br />
dupli [] = []<br />
dupli (x:xs) = x:x:dupli xs<br />
</haskell><br />
<br />
or, using list comprehension syntax:<br />
<br />
<haskell><br />
dupli list = concat [[x,x] | x <- list]<br />
</haskell><br />
<br />
or, using the list monad:<br />
<haskell><br />
dupli xs = xs >>= (\x -> [x,x])<br />
</haskell><br />
<br />
or, using concatMap:<br />
<haskell><br />
dupli = concatMap (\x -> [x,x])<br />
</haskell><br />
<br />
or, using foldr:<br />
<haskell><br />
dupli = foldr (\ x xs -> x : x : xs) []<br />
</haskell><br />
<br />
== Problem 15 ==<br />
<br />
(**) Replicate the elements of a list a given number of times.<br />
<br />
<pre><br />
Example:<br />
* (repli '(a b c) 3)<br />
(A A A B B B C C C)<br />
<br />
Example in Haskell:<br />
> repli "abc" 3<br />
"aaabbbccc"<br />
</pre><br />
<br />
Solution:<br />
<haskell><br />
repli :: [a] -> Int -> [a]<br />
repli xs n = concatMap (replicate n) xs<br />
</haskell><br />
<br />
== Problem 16 ==<br />
(**) Drop every N'th element from a list.<br />
<br />
<pre><br />
Example:<br />
* (drop '(a b c d e f g h i k) 3)<br />
(A B D E G H K)<br />
<br />
Example in Haskell:<br />
*Main> dropEvery "abcdefghik" 3<br />
"abdeghk"<br />
</pre><br />
<br />
An iterative solution:<br />
<haskell><br />
dropEvery :: [a] -> Int -> [a]<br />
dropEvery [] _ = []<br />
dropEvery (x:xs) n = dropEvery' (x:xs) n 1 where<br />
dropEvery' (x:xs) n i = (if (n `divides` i) then<br />
[] else<br />
[x])<br />
++ (dropEvery' xs n (i+1))<br />
dropEvery' [] _ _ = []<br />
divides x y = y `mod` x == 0<br />
</haskell><br />
<br />
or an alternative iterative solution:<br />
<haskell><br />
dropEvery :: [a] -> Int -> [a]<br />
dropEvery list count = helper list count count<br />
where helper [] _ _ = []<br />
helper (x:xs) count 1 = helper xs count count<br />
helper (x:xs) count n = x : (helper xs count (n - 1))<br />
</haskell><br />
<br />
or using zip:<br />
<haskell><br />
dropEvery n = map snd . filter ((n/=) . fst) . zip (cycle [1..n])<br />
</haskell><br />
<br />
== Problem 17 ==<br />
<br />
(*) Split a list into two parts; the length of the first part is given.<br />
<br />
Do not use any predefined predicates.<br />
<br />
<pre><br />
Example:<br />
* (split '(a b c d e f g h i k) 3)<br />
( (A B C) (D E F G H I K))<br />
<br />
Example in Haskell:<br />
*Main> split "abcdefghik" 3<br />
("abc", "defghik")<br />
</pre><br />
<br />
Solution using take and drop:<br />
<haskell><br />
split xs n = (take n xs, drop n xs)<br />
</haskell><br />
<br />
Alternatively, we have the following recursive solution:<br />
<haskell><br />
split :: [a] -> Int -> ([a], [a])<br />
split [] _ = ([], [])<br />
split l@(x : xs) n | n > 0 = (x : fst splitSub, snd splitSub)<br />
| otherwise = ([], l)<br />
where splitSub = split xs (n - 1)<br />
</haskell><br />
<br />
Note that this function, with the parameters in the other order, exists as <hask>splitAt</hask>.<br />
<br />
<br />
== Problem 18 ==<br />
<br />
(**) Extract a slice from a list.<br />
<br />
Given two indices, i and k, the slice is the list containing the elements between the i'th and k'th element of the original list (both limits included). Start counting the elements with 1.<br />
<br />
<pre><br />
Example:<br />
* (slice '(a b c d e f g h i k) 3 7)<br />
(C D E F G)<br />
<br />
Example in Haskell:<br />
*Main> slice ['a','b','c','d','e','f','g','h','i','k'] 3 7<br />
"cdefg"<br />
</pre><br />
<br />
Solution:<br />
<haskell><br />
slice xs (i+1) k = take (k-i) $ drop i xs<br />
</haskell><br />
<br />
== Problem 19 ==<br />
<br />
(**) Rotate a list N places to the left.<br />
<br />
Hint: Use the predefined functions length and (++).<br />
<br />
<pre><br />
Examples:<br />
* (rotate '(a b c d e f g h) 3)<br />
(D E F G H A B C)<br />
<br />
* (rotate '(a b c d e f g h) -2)<br />
(G H A B C D E F)<br />
<br />
Examples in Haskell:<br />
*Main> rotate ['a','b','c','d','e','f','g','h'] 3<br />
"defghabc"<br />
<br />
*Main> rotate ['a','b','c','d','e','f','g','h'] (-2)<br />
"ghabcdef"<br />
</pre><br />
<br />
Solution:<br />
<haskell><br />
rotate [] _ = []<br />
rotate l 0 = l<br />
rotate (x:xs) (n+1) = rotate (xs ++ [x]) n<br />
rotate l n = rotate l (length l + n)<br />
</haskell><br />
<br />
There are two separate cases:<br />
* If n > 0, move the first element to the end of the list n times.<br />
* If n < 0, convert the problem to the equivalent problem for n > 0 by adding the list's length to n.<br />
<br />
or using cycle:<br />
<haskell><br />
rotate xs n = take len . drop (n `mod` len) . cycle $ xs<br />
where len = length xs<br />
</haskell><br />
<br />
or<br />
<br />
<haskell><br />
rotate xs n = if n >= 0 then<br />
drop n xs ++ take n xs<br />
else let l = ((length xs) + n) in<br />
drop l xs ++ take l xs<br />
</haskell><br />
<br />
or<br />
<br />
<haskell><br />
rotate xs n = drop nn xs ++ take nn xs<br />
where <br />
nn = n `mod` length xs<br />
</haskell><br />
<br />
== Problem 20 ==<br />
<br />
(*) Remove the K'th element from a list.<br />
<br />
Example in Prolog:<br />
<pre><br />
?- remove_at(X,[a,b,c,d],2,R).<br />
X = b<br />
R = [a,c,d]<br />
</pre><br />
<br />
Example in Lisp:<br />
<pre><br />
* (remove-at '(a b c d) 2)<br />
(A C D)<br />
</pre><br />
(Note that this only returns the residue list, while the Prolog version also returns the deleted element.)<br />
<br />
Example in Haskell:<br />
<pre><br />
*Main> removeAt 1 "abcd"<br />
('b',"acd")<br />
</pre><br />
<br />
Solution:<br />
<haskell><br />
removeAt :: Int -> [a] -> (a, [a])<br />
removeAt k xs = case back of<br />
[] -> error "removeAt: index too large"<br />
x:rest -> (x, front ++ rest)<br />
where (front, back) = splitAt k xs<br />
</haskell><br />
<br />
Simply use the <hask>splitAt</hask> to split after k elements.<br />
If the original list has fewer than k+1 elements, the second list will be empty, and there will be no element to extract.<br />
Note that the Prolog and Lisp versions treat 1 as the first element in the list, and the Lisp version appends NIL elements to the end of the list if k is greater than the list length.<br />
<br />
or <br />
<br />
<haskell><br />
removeAt n xs = (xs!!n,take n xs ++ drop (n+1) xs)<br />
</haskell><br />
<br />
[[Category:Tutorials]]</div>Scvalexhttps://wiki.haskell.org/index.php?title=99_questions/1_to_10&diff=2066899 questions/1 to 102008-04-23T15:51:38Z<p>Scvalex: added another solution to problem 9</p>
<hr />
<div>__NOTOC__<br />
<br />
This is part of [[H-99:_Ninety-Nine_Haskell_Problems|Ninety-Nine Haskell Problems]], based on [https://prof.ti.bfh.ch/hew1/informatik3/prolog/p-99/ Ninety-Nine Prolog Problems] and [http://www.ic.unicamp.br/~meidanis/courses/mc336/2006s2/funcional/L-99_Ninety-Nine_Lisp_Problems.html Ninety-Nine Lisp Problems].<br />
<br />
If you want to work on one of these, put your name in the block so we know someone's working on it. Then, change n in your block to the appropriate problem number, and fill in the <Problem description>,<example in lisp>,<example in Haskell>,<solution in haskell> and <description of implementation> fields. <br />
<br />
== Problem 1 ==<br />
<br />
(*) Find the last element of a list.<br />
<br />
(Note the the Lisp transcription of this problem is incorrect.)<br />
<br />
Example in Haskell:<br />
<br />
<haskell><br />
Prelude> myLast [1,2,3,4]<br />
4<br />
Prelude> myLast ['x','y','z']<br />
'z'<br />
</haskell><br />
<br />
Solutions:<br />
<br />
<haskell><br />
myLast :: [a] -> a<br />
myLast [x] = x<br />
myLast (_:xs) = myLast xs<br />
</haskell><br />
<br />
<haskell><br />
myLast :: [a] -> a<br />
myLast = foldr1 (const id)<br />
</haskell><br />
<br />
The <hask>Prelude</hask> also provides the function <hask>last</hask>.<br />
<br />
== Problem 2 ==<br />
<br />
(*) Find the last but one element of a list.<br />
<br />
(Note the the Lisp transcription of this problem is incorrect.)<br />
<br />
Example in Haskell:<br />
<br />
<haskell><br />
Prelude> myButLast [1,2,3,4]<br />
3<br />
Prelude> myButLast ['a'..'z']<br />
'y'<br />
</haskell><br />
<br />
Solutions:<br />
<br />
<haskell><br />
myButLast :: [a] -> a<br />
myButLast = last . init<br />
</haskell><br />
<br />
<haskell><br />
myButLast :: [a] -> a<br />
myButLast [x,_] = x<br />
myButLast (_:xs) = myButLast xs<br />
</haskell><br />
<br />
== Problem 3 ==<br />
<br />
(*) Find the K'th element of a list. The first element in the list is number 1.<br />
<br />
Example:<br />
<br />
<pre><br />
* (element-at '(a b c d e) 3)<br />
C<br />
</pre><br />
<br />
Example in Haskell:<br />
<br />
<haskell><br />
Prelude> elementAt [1,2,3] 2<br />
2<br />
Prelude> elementAt "haskell" 5<br />
'e'<br />
</haskell><br />
<br />
Solution:<br />
<br />
This is (almost) the infix operator !! in Prelude, which is defined as:<br />
<br />
<haskell><br />
(!!) :: [a] -> Int -> a<br />
(x:_) !! 0 = x<br />
(_:xs) !! n = xs !! (n-1)<br />
</haskell><br />
<br />
Except this doesn't quite work, because !! is zero-indexed, and element-at should be one-indexed. So:<br />
<br />
<haskell><br />
elementAt :: [a] -> Int -> a<br />
elementAt list i = list !! (i-1)<br />
</haskell><br />
<br />
== Problem 4 ==<br />
<br />
(*) Find the number of elements of a list.<br />
<br />
Example in Haskell:<br />
<br />
<haskell><br />
Prelude> myLength [123, 456, 789]<br />
3<br />
Prelude> myLength "Hello, world!"<br />
13<br />
</haskell><br />
<br />
Solutions:<br />
<br />
<haskell><br />
myLength :: [a] -> Int<br />
myLength [] = 0<br />
myLength (_:xs) = 1 + myLength xs<br />
</haskell><br />
<br />
<haskell><br />
myLength :: [a] -> Int<br />
myLength = foldr (\x n -> n + 1) 0<br />
</haskell><br />
<br />
This is <hask>length</hask> in <hask>Prelude</hask>.<br />
<br />
== Problem 5 ==<br />
<br />
(*) Reverse a list.<br />
<br />
Example in Haskell:<br />
<br />
<haskell><br />
Prelude> reverse "A man, a plan, a canal, panama!"<br />
"!amanap ,lanac a ,nalp a ,nam A"<br />
Prelude> reverse [1,2,3,4]<br />
[4,3,2,1]<br />
</haskell><br />
<br />
Solution: (defined in Prelude)<br />
<br />
<haskell><br />
reverse :: [a] -> [a]<br />
reverse = foldl (flip (:)) []<br />
</haskell><br />
<br />
The standard definition is concise, but not very readable. Another way to define reverse is:<br />
<br />
<haskell><br />
reverse :: [a] -> [a]<br />
reverse [] = []<br />
reverse (x:xs) = reverse xs ++ [x]<br />
</haskell><br />
<br />
However this definition is more wasteful than the one in Prelude as it repeatedly reconses the result as it is accumulated. The following variation avoids that, and thus computationally closer to the Prelude version.<br />
<br />
<haskell><br />
reverse :: [a] -> [a]<br />
reverse list = reverse' list []<br />
where<br />
reverse' [] reversed = reversed<br />
reverse' (x:xs) reversed = reverse' xs (x:reversed)<br />
</haskell> <br />
<br />
== Problem 6 ==<br />
<br />
(*) Find out whether a list is a palindrome. A palindrome can be read forward or backward; e.g. (x a m a x).<br />
<br />
Example in Haskell:<br />
<br />
<haskell><br />
*Main> isPalindrome [1,2,3]<br />
False<br />
*Main> isPalindrome "madamimadam"<br />
True<br />
*Main> isPalindrome [1,2,4,8,16,8,4,2,1]<br />
True<br />
</haskell><br />
<br />
Solution:<br />
<br />
<haskell><br />
isPalindrome :: (Eq a) => [a] -> Bool<br />
isPalindrome xs = xs == (reverse xs)<br />
</haskell><br />
<br />
== Problem 7 ==<br />
<br />
(**) Flatten a nested list structure.<br />
<br />
Transform a list, possibly holding lists as elements into a `flat' list by replacing each list with its elements (recursively).<br />
<br />
Example:<br />
<br />
<pre><br />
* (my-flatten '(a (b (c d) e)))<br />
(A B C D E)<br />
</pre><br />
<br />
Example in Haskell:<br />
<br />
<haskell><br />
*Main> flatten (Elem 5)<br />
[5]<br />
*Main> flatten (List [Elem 1, List [Elem 2, List [Elem 3, Elem 4], Elem 5]])<br />
[1,2,3,4,5]<br />
*Main> flatten (List [])<br />
[]<br />
</haskell><br />
<br />
Solution:<br />
<br />
<haskell><br />
data NestedList a = Elem a | List [NestedList a]<br />
<br />
flatten :: NestedList a -> [a]<br />
flatten (Elem x) = [x]<br />
flatten (List x) = concatMap flatten x<br />
</haskell><br />
<br />
We have to define a new data type, because lists in Haskell are homogeneous.<br />
[1, [2, [3, 4], 5]] is a type error. Therefore, we must have a way of<br />
representing a list that may (or may not) be nested.<br />
<br />
Our NestedList datatype is either a single element of some type (Elem a), or a<br />
list of NestedLists of the same type. (List [NestedList a]). <br />
<br />
== Problem 8 ==<br />
<br />
(**) Eliminate consecutive duplicates of list elements.<br />
<br />
If a list contains repeated elements they should be replaced with a single copy of the element. The order of the elements should not be changed.<br />
<br />
<pre><br />
Example:<br />
* (compress '(a a a a b c c a a d e e e e))<br />
(A B C A D E)<br />
<br />
Example in Haskell:<br />
*Main> compress ['a','a','a','a','b','c','c','a','a','d','e','e','e','e']<br />
['a','b','c','a','d','e']<br />
</pre><br />
<br />
Solution:<br />
<haskell><br />
compress :: Eq a => [a] -> [a]<br />
compress = map head . group<br />
</haskell><br />
<br />
We simply group equal values together (group), then take the head of each. <br />
Note that (with GHC) we must give an explicit type to ''compress'' otherwise we get:<br />
<br />
<haskell><br />
Ambiguous type variable `a' in the constraint:<br />
`Eq a'<br />
arising from use of `group' <br />
Possible cause: the monomorphism restriction applied to the following:<br />
compress :: [a] -> [a]<br />
Probable fix: give these definition(s) an explicit type signature<br />
or use -fno-monomorphism-restriction<br />
</haskell><br />
<br />
We can circumvent the monomorphism restriction by writing ''compress'' this way (See: section 4.5.4 of [http://haskell.org/onlinereport the report]):<br />
<br />
<haskell>compress xs = map head $ group xs</haskell><br />
<br />
An alternative solution is<br />
<br />
<haskell><br />
compress [] = []<br />
compress [a] = [a]<br />
compress (x : y : xs) = (if x == y then [] else [x]) ++ compress (y : xs)<br />
</haskell><br />
<br />
== Problem 9 ==<br />
<br />
(**) Pack consecutive duplicates of list elements into sublists.<br />
If a list contains repeated elements they should be placed in separate sublists.<br />
<br />
<pre><br />
Example:<br />
* (pack '(a a a a b c c a a d e e e e))<br />
((A A A A) (B) (C C) (A A) (D) (E E E E))<br />
<example in lisp><br />
<br />
Example in Haskell:<br />
*Main> pack ['a', 'a', 'a', 'a', 'b', 'c', 'c', 'a', 'a', 'd', 'e', 'e', 'e', 'e']<br />
["aaaa","b","cc","aa","d","eeee"]<br />
</pre><br />
<br />
Solution:<br />
<haskell><br />
pack (x:xs) = let (first,rest) = span (==x) xs<br />
in (x:first) : pack rest<br />
pack [] = []<br />
</haskell><br />
<br />
A more verbose solution is<br />
<haskell><br />
pack :: Eq a => [a] -> [[a]]<br />
pack [] = []<br />
pack (x:xs) = (x:first) : pack rest<br />
where<br />
getReps [] = ([], [])<br />
getReps (y:ys)<br />
| y == x = let (f,r) = getReps ys in (y:f, r)<br />
| otherwise = ([], (y:ys))<br />
(first,rest) = getReps xs<br />
</haskell><br />
<br />
This is implemented as <hask>group</hask> in <hask>Data.List</hask>.<br />
<br />
== Problem 10 ==<br />
<br />
(*) Run-length encoding of a list.<br />
Use the result of problem P09 to implement the so-called run-length encoding data compression method. Consecutive duplicates of elements are encoded as lists (N E) where N is the number of duplicates of the element E.<br />
<br />
Example:<br />
<pre><br />
* (encode '(a a a a b c c a a d e e e e))<br />
((4 A) (1 B) (2 C) (2 A) (1 D)(4 E))<br />
</pre><br />
<br />
Example in Haskell:<br />
<pre><br />
encode "aaaabccaadeeee"<br />
[(4,'a'),(1,'b'),(2,'c'),(2,'a'),(1,'d'),(4,'e')]<br />
</pre><br />
<br />
Solution:<br />
<haskell><br />
encode xs = map (\x -> (length x,head x)) (group xs)<br />
</haskell><br />
<br />
which can also be expressed as a list comprehension:<br />
<br />
<haskell><br />
[(length x, head x) | x <- group xs]<br />
</haskell><br />
<br />
Or writing it [[Pointfree]]:<br />
<br />
<haskell><br />
encode :: Eq a => [a] -> [(Int, a)]<br />
encode = map (\x -> (length x, head x)) . group<br />
</haskell><br />
<br />
Or (ab)using the "&&&" arrow operator for tuples:<br />
<br />
<haskell><br />
encode :: Eq a => [a] -> [(Int, a)]<br />
encode xs = map (length &&& head) $ group xs<br />
</haskell><br />
[[Category:Tutorials]]</div>Scvalex