First, some imports. I’m not counting these as lines of code since to me a line of code is something that can contain a bug.

import qualified Data.List.Key as K
import qualified Data.Map as M

First we define the rule that the game of life is based on: cells stay alive if they have 2 or 3 neighbors, and they become alive if they have 3 neighbors.

rule (cy,cx) m = elem ns $ if alive (cy,cx) then [2,3] else [3] where
    ns = sum [1 | y <- [-1..1], x <- [-1..1], (y,x) /= (0,0), alive (cy+y,cx+x)]
    alive c = M.lookup c m == Just 'x'

We calculate the next generation of a grid by determining the rectangle that holds the active cells, adding a one-cell border (since that’s the furthest influence distance) and calculating the new state for each cell in the resulting rectangle.

step m = if null on then M.empty else M.fromList
    [((y,x),if rule (y,x) m then 'x' else '.') | y <- range fst, x <- range snd]
    where on = M.keys $ M.filter (== 'x') m
          range f = [minimum (map f on) - 1..maximum (map f on) + 1]

Next, we need some functions to load and show a generation:

load s = M.fromList [((y,x),c) | (y,l)<-zip [0..] $ lines s, (x,c)<-zip [0..] l]

display = mapM_ (putStrLn . map snd) . ([]   . K.group (fst . fst) . M.assocs

The program reads the input from a text file that holds the starting situation, e.g.

.....
.xxx.
.x...
..x..
.....

and then prints all of the subsequent generations until the pattern stabilizes, i.e. it finds two subsequent identical generations.

main = mapM_ (display . snd) . takeWhile (uncurry (/=)) .
    (\l -> zip l $ tail l) . iterate step . load =<< readFile "life.txt"

And that’s it. A cool little program that’s even one line under our budget of 12.

A quick import:

import Data.List

The code is pretty straightforward: just take all the numbers up to 180 that cannot be created by a linear combination of 6, 9 and 20.

notMcNuggets :: [Integer]
notMcNuggets = [1..180] \\
    [a+b+c | a <- [0,6..180], b <- [0,9..180-a], c <- [0,20..180-a-b]]

To test whether everything works correctly:

main :: IO ()
main = print notMcNuggets

Yup. Nice and simple.

A quick import to making printing slightly more convenient:

import Text.Printf

Calculating Pascal’s triangle is trivial:

pascal :: [[Integer]]
pascal = iterate (\prev -> 1 : zipWith (+) prev (tail prev) ++ [1]) [1]

To display the triangle correctly, we need to prepend the appropriate amount of spacing to each line based on the longest (i.e. last) line.

prettyPascal :: Int -> IO ()
prettyPascal n = mapM_ (\r -> printf "%*s\n" (div (longest + length r) 2) r) rows
    where rows = map (unwords . map show) $ take (n + 1) pascal
          longest = length $ last rows

An that’s all there is to it. A quick test to see if everything is working proprely:

main :: IO ()
main = prettyPascal 10

Since we’ll be doing a lot of moving left and right in the program and cells a zipper is an obvious data structure to use.

import Data.List.Zipper

Running a program is a simple matter of executing all the steps until we arrive at the end, starting with a zeroed-out list.

run :: String -> IO String
run = fmap toList . flip step (fromList $ replicate 30000 '\NUL') . fromList

step :: Zipper Char -> Zipper Char -> IO (Zipper Char)
step prog s = if endp prog then return s else
              uncurry step =<< instruction (cursor prog) prog s

Using the zipper, most of the instructions are fairly trivial. The brackets are the only ones that require a bit of extra work.

instruction :: Char -> Zipper Char -> Zipper Char -> IO (Zipper Char, Zipper Char)
instruction '<' prog s = return (right prog, left s)
instruction '>' prog s = return (right prog, right s)
instruction '+' prog s = return (right prog, replace (succ $ cursor s) s)
instruction '-' prog s = return (right prog, replace (pred $ cursor s) s)
instruction '.' prog s = putStr [cursor s] >> return (right prog, s)
instruction ',' prog s = fmap ((,) (right prog) . flip replace s) getChar
instruction '[' prog s = return $ (if cursor s == '\NUL' then
                             right $ move right '[' ']' prog else right prog, s)
instruction ']' prog s = return (move left ']' '[' prog, s)
instruction _   prog s = return (right prog, s)

Moving the cursor to the corresponding bracket requires stepping over any nested sets of brackets.

move :: (Zipper Char -> Zipper Char) -> Char -> Char -> Zipper Char -> Zipper Char
move dir open close = f 0 . dir where
    f 0 z | cursor z == close = z
    f n z = f (if cursor z == open  then n + 1 else
               if cursor z == close then n - 1 else n) $ dir z

All that's left to do is to run the program, which prints the expected Hello World message.

main :: IO ()
main = run "++++++++++[>+++++++>++++++++++>+++>+<\
 \<<<-]>++.>+.+++++++..+++.>++.<<++++++\
 \+++++++++.>.+++.------.--------.>+.>." >> return ()

A quick import:

import Data.List

The tetrahedral numbers are based on the triangular numbers, so let’s start with those.

triangular :: [Integer]
triangular = scanl1 (+) [1..]

The tetrahedral numbers are formed in much the same way as the triangular ones.

tetrahedral :: [Integer]
tetrahedral = scanl1 (+) triangular

All that’s left to do is to is to find the base of the pyramid.

main :: IO ()
main = print . maybe 0 succ $
       findIndex (== 169179692512835000) tetrahedral

Some imports:

import Data.List
import qualified Data.Map as M

To find the first non-repeated element, we mark each element as unique and insert them into a map. When a duplicate element is found, we remove its unique status. Afterwards, we search the list for the first unique element.

firstUnique :: Ord a => [a] -> Maybe a
firstUnique xs = find (M.fromListWith (\_ _ -> False)
                           (zip xs $ repeat True) M.!) xs

Some tests to see if everything is working properly:

main :: IO ()
main = do print $ firstUnique "aabcbcdeef"   == Just 'd'
          print $ firstUnique "aabcbcfeed"   == Just 'f'
          print $ firstUnique "aabcbcdeefdf" == Nothing

A quick import:

import qualified Data.List.Key as K

Sorting by length is trivial.

byLength :: [[a]] -> [[a]]
byLength = K.sort length

Sorting by frequency of the list lengths is a bit more complicated since we need to group and ungroup the lists, but still a one-liner.

byLengthFreq :: [[a]] -> [[a]]
byLengthFreq = concat . byLength . K.group length . byLength

Some tests to see if everything is working properly:

main :: IO ()
main = do print $ byLength ["abc","de","fgh","de","ijkl","mn","o"]
                        == ["o","de","de","mn","abc","fgh","ijkl"]
          print $ byLengthFreq ["abc","de","fgh","de","ijkl","mn","o"]
                            == ["o","ijkl","abc","fgh","de","de","mn"]

I hope you guys have enjoyed this blog over the past few years and I hope I’ve gotten at least a few of you to try out Haskell. If you haven’t, what are you waiting for? Go download the Haskell Platform and get started! Looking for something to practise on? Go do some of the exercises from Programming Praxis. I’m looking forward to reading your solutions.

Regards,
Remco Niemeijer

Some imports:

import Data.Ratio
import Text.Printf

To get proper rounding we first multiply by 32 and then see how many feet, inches and fractions of an inch there are.

toCarpenter :: RealFrac a => a -> (Int, Int, Ratio Int)
toCarpenter l = (feet, div r 32, mod r 32 % 32) where
    (feet, r) = divMod (round $ l * 32) (32 * 12)

Formatting the text is a unfortunately a tad unwieldy due to the number of special cases.

feetAndInches :: RealFrac a => a -> String
feetAndInches l = case toCarpenter l of
    (0,0,0) -> "0 feet 0 inches"
    (f,i,t) -> showUnit "foot" "feet" (f % 1) ++
               (if f > 0 && (i%1 + t) > 0 then " " else "") ++
               showUnit "inch" "inches" (i % 1 + t)
    where
    showUnit _ _ 0 = ""
    showUnit s m n = printf "%s %s" (showVal n) $ if n <= 1 then s else m
    showVal v | d == 1    = show n
              | v < 1     = printf "%d/%d" n d
              | otherwise = printf "%d and %d/%d" (div n d) (mod n d) d
              where (n,d) = (numerator v, denominator v)

Some tests to see if everything is working properly:

main :: IO ()
main = do print $ feetAndInches 0       == "0 feet 0 inches"
          print $ feetAndInches 0.2785  == "9/32 inch"
          print $ feetAndInches 1.6895  == "1 and 11/16 inches"
          print $ feetAndInches 11.9999 == "1 foot"
          print $ feetAndInches 12.2785 == "1 foot 9/32 inch"
          print $ feetAndInches 71.9999 == "6 feet"
          print $ feetAndInches 72      == "6 feet"
          print $ feetAndInches 72.3492 == "6 feet 11/32 inch"
          print $ feetAndInches 72.9999 == "6 feet 1 inch"
          print $ feetAndInches 73      == "6 feet 1 inch"
          print $ feetAndInches 73.0135 == "6 feet 1 inch"
          print $ feetAndInches 73.0185 == "6 feet 1 and 1/32 inches"
          print $ feetAndInches 73.8218 == "6 feet 1 and 13/16 inches"

To make the results a bit easier to work with we make a data type with the days of the week.

data Weekday = Sun | Mon | Tue | Wed | Thu | Fri | Sat deriving (Enum, Eq, Show)

The algorithms are just a bit a math.

gauss :: Int -> Int -> Int -> Weekday
gauss y m d = toEnum $ mod (d + floor (2.6 * fromIntegral
  (mod (m - 2) 12) - 0.2) + y' + div y' 4 + div c 4 - 2*c) 7 where
    (c,y') = divMod (if m < 3 then y - 1 else y) 100

sakamoto :: Int -> Int -> Int -> Weekday
sakamoto y m d = toEnum $ mod (y + div y 4 - div y 100 +
    div y 400 + [0,3,2,5,0,3,5,1,4,6,2,4] !! (m - 1) + d) 7

conway :: Int -> Weekday
conway y = toEnum $ mod (q + r + div r 4 + 5*(c+1) + div c 4 + 4) 7
    where (c, (q,r)) = (div y 100, divMod (mod y 100) 12)

Some tests to see if everything is working properly:

main :: IO ()
main = do print $ gauss 2011 6 24 == Fri
          print $ sakamoto 2011 6 24 == Fri
          print $ conway 2011 == Mon