Programming Praxis – Fibonacci Numbers

In today’s Programming Praxis we have to provide three different methods of calculating the ever-popular Fibonacci numbers; one exponential, one linear and one logarithmic. Let’s get started, shall we?

Some imports:

import Data.List
import Criterion.Main

The naive exponential solution is trivial:

fibexp :: Int -> Integer
fibexp 0 = 0
fibexp 1 = 1
fibexp n = fibexp (n - 1) + fibexp (n - 2)

For the linear method, we use the textbook lazy evaluation-based approach:

fiblin :: Int -> Integer
fiblin n = fibs !! n where fibs = 0:1:zipWith (+) fibs (tail fibs)

The logarithmic solution requires two helper functions: the matrix multiplication function from a previous exercise and a way of raising a matrix to a power in log(n) time.

mult :: Num a => [[a]] -> [[a]] -> [[a]]
mult a b = [map (sum . zipWith (*) r) $ transpose b | r <- a]

matrixpower :: [[Integer]] -> Int -> [[Integer]]
matrixpower m 1 = m
matrixpower m n = (if even n then id else mult m) $
                  matrixpower (mult m m) (div n 2)

All that’s left to do to calculate Fibonacci numbers is raise the given matrix to the correct power and taking the lower-left element.

fiblog :: Int -> Integer
fiblog 0 = 0
fiblog n = matrixpower [[1,1],[1,0]] n !! 1 !! 0

To benchmark the different solutions, we use the Criterion library.

main :: IO ()
main = defaultMain [bench "exp" $ nf fibexp 25
                   ,bench "lin" $ nf fiblin 25000
                   ,bench "log" $ nf fiblog 25000
                   ]

This gives the following timings: 174 ms for the exponential version, 69 ms for the linear one and 643 microseconds for the logarithmic solution, so we get a 100-fold speedup between the linear and logarithmic version at the cost of a factor of 6 increase in code size. Not a bad trade-off.

Programming Praxis – Happy Numbers

Today’s Programming Praxis problem is a pretty simple one, but it comes with a time limit. We have 15 minutes to write a function that finds all the happy numbers up to a given limit. The version below took me around 4 minutes. Let’s go into the explanation.

While we could write the function directly, we’ll split it up in two: one to determine if a single number is happy and one to get all the required happy numbers. We model the happy number algorithm with basic recursion. We keep a list of all previously “visited” numbers to detect loops.

isHappy :: (Read a, Integral a) => a -> Bool
isHappy = f [] where
    f _  1 = True
    f xs n = notElem n xs && f (n:xs) (sum . map (^ 2) $ digits n)
    digits = map (read . return) . show

Once we know if a single number is happy, determining all of them is just a simple matter of filtering all the numbers less than the limit.

happyUpto :: (Read a, Integral a) => a -> [a]
happyUpto n = filter isHappy [1..n - 1]

All that’s left is actually running the algorithm.

main :: IO ()
main = print $ happyUpto 50

Looks like everything’s working correctly. Of course, it would be somewhat embarrassing if it didn’t, since this is only a fraction more complicated than FizzBuzz.

Programming Praxis – Solving Systems Of Linear Equations

In yesterday’s Programming Praxis exercise our task is to implement some more matrix-related functions, specifically LU and LUP decomposition and a solver for systems of linear equations. The provided Scheme solution comes in at 69 lines. Let’s see what we can do about that.

Some imports:

import Control.Arrow
import Data.List
import qualified Data.List.Key as K

We’re going to need the matrix multiplication function we defined last time.

mult :: Num a => [[a]] -> [[a]] -> [[a]]
mult a b = [map (sum . zipWith (*) r) $ transpose b | r <- a]

Since we will be using Gauss elimination, we need a way to eliminate a single row.

elim :: Fractional a => [a] -> [a] -> [a]
elim ~(x:xs) ~(y:ys) = zipWith (-) ys $ map (y / x *) xs

Also, we need to construct identity matrices.

identity :: Num a => [[a]] -> [[a]]
identity = zipWith (zipWith const) (iterate (0: ) (1 : repeat 0))

With that out of the way, we can defined LU decomposition.

lu :: Fractional a => [[a]] -> ([[a]], [[a]])
lu = unzip . map unzip . f where
    f []      = []
    f ~(x:xs) = zip (1 : repeat 0) x :
                zipWith (:) (map (\(y:_) -> (y / head x, 0)) xs)
                            (f $ map (elim x) xs)

LUP decomposition is the same as LU decomposition, except that the matrix is permuted so that the pivot at each step is maximized. Therefore, we need a way to compute the correct permutation matrix.

perm :: (Fractional a, Ord a) => [[a]] -> [[a]]
perm m = f $ zip (identity m) m where
    f [] = []
    f xs = a : f (map (second $ elim b) $ delete (a,b) xs)
           where (a,b) = K.maximum (abs . head . snd) xs

As mentioned, once we have the permutation matrix, LUP decomposition is trivial.

lup :: (Fractional a, Ord a) => [[a]] -> ([[a]], [[a]], [[a]])
lup xs = (perm xs, l, u) where (l,u) = lu $ mult (perm xs) xs

And finally, the function to solve systems of equations. On a related note, I’d really appreciate it if algorithm descriptions came with pseudocode that wasn’t stateful. This one took some thinking to convert to a functional style.

lupsolve :: (Fractional a, Ord a) => [[a]] -> [a] -> [a]
lupsolve a b = f y u where
    (p,l,u) = lup a
    y = foldl (\x (l', pb') -> x ++ [pb' - sum (zipWith (*) x l')])
              [] (zip l (concat . mult p $ map return b))
    f _ [] = []
    f ~(y':ys) ~((r:rs):us) = (y' - sum (zipWith (*) rs z)) / r : z
        where z = (f ys $ map tail us)

As usual, a test to see if everything’s working correctly:

main :: IO ()
main = do print $ lu [[ 2, 3, 1, 5]
                     ,[ 6,13, 5,19]
                     ,[ 2,19,10,23]
                     ,[ 4,10,11,31]]
          print $ lup [[ 2, 0,   2,3/5]
                      ,[ 3, 3,   4, -2]
                      ,[ 5, 5,   4,  2]
                      ,[-1,-2,17/5, -1]]
          print $ lupsolve [[1,2,0],[3,5,4],[5,6,3]]
                           [1/10, 25/2, 103/10]

Yep (for more accurate results, use Ratio Ints instead of the default Floats). And at 20 lines, that’s less than a third of the Scheme solution. Not too bad.

Programming Praxis – Word Cube

In today’s Programming Praxis exercise our task is to write a program to solve Word Cube puzzles, in which you need to find as many words as possible that you can make from nine given letters. The provided Scheme solution is 21 lines, let’s see if we can do better.

Some imports:

import Data.Char
import Data.List

There are three criteria for valid solutions: the word must be at least 4 characters, it must contain the letter in the center and you must be able to make it from the nine letters.

solve :: String -> [String] -> [String]
solve c = filter (\w -> length w > 3 && elem (c !! 4) w && null (w \\ c))

All that’s left to do is load the dictionary, pass it to the solve function and print the results.

wordcube :: String -> IO ()
wordcube cube = mapM_ putStrLn . solve cube .
                lines . map toLower =<< readFile "words.txt"

Straightforward enough. A quick test to see if everything is working correctly:

main :: IO ()
main = wordcube "ncbcioune"

Yup. Not bad at one seventh the size of the Scheme solution.

Programming Praxis – Chaocipher

In today’s Programming Praxis we have another cipher on our hands, called chaocipher. The provided Scheme solution is 25 lines, so let’s see if we can improve that.

Some imports:

import Control.Arrow
import Data.List

One of the steps of the algorithm is taking the first n characters and moving them to the end.

seek :: Int -> [a] -> [a]
seek to = uncurry (flip (++)) . splitAt to

Another step is taking a group of characters between two indices and applying the previous function to them. The Scheme solution combines these two functions in one, but I prefer to keep them separate.

shift :: Int -> Int -> [a] -> [a]
shift from to = (\((a,b),c) -> a ++ seek 1 b ++ c) .
                first (splitAt from) . splitAt to

With those two out of the way, ciphering in either direction is a matter of finding the input character on the appropriate wheel, outputting the corresponding character from the other wheel and repeating the process after modifying the wheels.

cipher :: Eq a => Bool -> [a] -> [a] -> [a] -> [a]
cipher _ _ _ []     = []
cipher e l r (x:xs) = to !! i : cipher e (shift 1 14 $ seek i l)
                      (shift 2 14 . shift 0 26 $ seek i r) xs
    where Just i = elemIndex x from
          (from, to) = if e then (r, l) else (l, r)

Let’s add some convenience functions for encoding and decoding:

encipher, decipher :: Eq a => [a] -> [a] -> [a] -> [a]
encipher = cipher True
decipher = cipher False

Of course we need to check if everything is working correctly:

main :: IO ()
main = do let l = "HXUCZVAMDSLKPEFJRIGTWOBNYQ"
              r = "PTLNBQDEOYSFAVZKGJRIHWXUMC"
              decoded = "WELLDONEISBETTERTHANWELLSAID"
              encoded = "OAHQHCNYNXTSZJRRHJBYHQKSOUJY"
          print $ encipher l r decoded == encoded
          print $ decipher l r encoded == decoded

Everything looks to be working alright, and at 10 lines we reduced the Scheme version by 60%. Not bad.

Programming Praxis – Chronological Listing Of Exercises

In today’s Programming Praxis exercise our goal is to replicate a script Phil wrote to generate chronological and reverse chronological lists of all of his posts. He did it in 24 lines of AWK, so let’s see how Haskell measures up.

Some imports:

import Data.List
import Data.List.Split
import Text.Printf
import Text.Regex.Posix

We need a function to display the name of a month.

toMonth :: Int -> String
toMonth m = chunk 3 "JanFebMarAprMayJunJulAugSepOctNovDec" !! (m - 1)

Generating the html for a post is roughly the same as in his version, save for the fact that I removed a bit of duplication in the links.

item :: [[String]] -> String
item xs = printf
    "<tr><td>%s</td><td>%02s %s %s</td><td>%s: %s</td>\
    \<td>%s%s<a href=\"http://programmingpraxis.codepad.org/%s\">\
    \codepad</a></td></tr>"
    (g "number") (g "pubday") (toMonth . read $ g "pubmon") (g "pubyear")
    (link "" (g "title")) (g "blurb") (link "" "exercise")
    (link ("/" ++ g "soln") "solution") (g "codepad")
    where g x = maybe "" last $ find ((== x) . head) xs
          link :: String -> String -> String
          link = printf "<a href=\"/%s/%02s/%02s/%s%s/\">%s</a>"
                 (g "pubyear") (g "pubmon") (g "pubday") (g "file")

Generating a list of items is pretty self-explanatory: separate the blocks, filter out the posts, parse the properties and generate the necessary html.

items :: String -> [String]
items = map (item . map (splitOn "\t") . lines) .
        filter (=~ "^number\t[1-9][0-9]*$") . splitOn "\n\n"

All that’s left to do is sort the items as required and put them in a table. Like the original implementation, this version requires that the file containing the list is sorted chronologically.

listing :: ([String] -> [String]) -> String -> String
listing f xs = "<table cellpadding=\"10\">" ++
               concat (f $ items xs) ++ "</table>"

Let’s see if everything works:

main :: IO ()
main = do x <- readFile "praxis.info"
          putStrLn $ listing id x
          putStrLn $ listing reverse x

Yup. And at 15 lines, I think I’ll continue to use Haskell for my text munging needs.