abhin4v
/
rubyquiz
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Added Haddock documentation

master
Abhinav Sarkar 2012-10-27 13:36:30 +05:30
parent 1838543880
commit aa10f43dab
8 changed files with 237 additions and 160 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
AStar.hs
View File

@ -10,9 +10,15 @@ import qualified Data.Map as M
import Data.List (foldl') import Data.List (foldl')
import Data.Maybe (fromJust) import Data.Maybe (fromJust)
-- A* algorithm: Find a path from initial node to goal node using a heuristic function. -- | A* algorithm: Finds a path from initial node to goal node using a heuristic function.
-- Returns Nothing if no path found. Else returns Just (path cost, path). astar :: (Ord a, Ord b, Num b) =>
astar :: (Ord a, Ord b, Num b) => a -> a -> (a -> [(a, b)]) -> (a -> a -> b) -> Maybe (b, [a]) a -- ^ The start node
-> a -- ^ The goal node
-> (a -> [(a, b)]) -- ^ The function to get the next nodes and their
-- costs from a given node
-> (a -> a -> b) -- ^ The heuristic function to estimate the cost of
-- going from a give node to the target node
-> Maybe (b, [a]) -- ^ Nothing if no path found. Else @Just (path cost, path)@
astar initNode goalNode nextNode hueristic = astar initNode goalNode nextNode hueristic =
astar' (PQ.singleton (hueristic initNode goalNode) (initNode, 0)) astar' (PQ.singleton (hueristic initNode goalNode) (initNode, 0))
S.empty (M.singleton initNode 0) M.empty S.empty (M.singleton initNode 0) M.empty

104
AmazingMazes.hs
View File

@ -1,46 +1,48 @@
{- {-|
A solution to rubyquiz 31 (http://rubyquiz.com/quiz31.html). A solution to rubyquiz 31 (<http://rubyquiz.com/quiz31.html>).
Generate a rectangular maze given its width and height. The maze should be /Generate a rectangular maze given its width and height. The maze should be/
solvable for any start and end positions and there should be only one possible /solvable for any start and end positions and there should be only one possible/
solution for any pair of start and end positions. /solution for any pair of start and end positions./
Generate the ASCII output representing the maze. /Generate the ASCII output representing the maze./
Find the solution of the maze. Produce ASCII output to visualize the solution. /Find the solution of the maze. Produce ASCII output to visualize the solution./
The maze generation algorithm used is recursive backtracking and the maze The maze generation algorithm used is recursive backtracking and the maze
solution algorithm used is A*. solution algorithm used is A* (from "AStar" module).
Usage: ./AmazingMazes <width> <height> <start_x> <start_y> <end_x> <end_y> Usage (Coordinates are zero based):
Coordinates are zero based.
abhinav@xj9:rubyquiz# bin/AmazingMazes 10 10 0 0 9 9 > ./AmazingMazes <width> <height> <start_x> <start_y> <end_x> <end_y>
+---+---+---+---+---+---+---+---+---+---+
| s > v | | |
+---+---+ +---+ + +---+ + +---+
| v < < | | | | | |
+ +---+---+---+---+---+ + + + +
| v | | | |
+ +---+---+---+ + +---+---+---+ +
| > > > v | | | > v |
+---+---+---+ + + +---+---+ + +
| | v < | | > > ^ | v |
+ + + +---+---+---+ +---+---+ +
| | | > > > > ^ | | v |
+ +---+---+---+---+---+---+ +---+ +
| | | | v < < |
+ + + + + + +---+ +---+---+
| | | | | | v < | |
+ + +---+---+ +---+ +---+ +---+
| | | | v < | |
+ +---+ + + + +---+---+---+ +
| | | > > > > e |
+---+---+---+---+---+---+---+---+---+---+
Copyright 2012 Abhinav Sarkar <abhinav@abhinavsarkar.net> Example:
> abhinav@xj9:rubyquiz# bin/AmazingMazes 10 10 0 0 9 9
> +---+---+---+---+---+---+---+---+---+---+
> | s > v | | |
> +---+---+ +---+ + +---+ + +---+
> | v < < | | | | | |
> + +---+---+---+---+---+ + + + +
> | v | | | |
> + +---+---+---+ + +---+---+---+ +
> | > > > v | | | > v |
> +---+---+---+ + + +---+---+ + +
> | | v < | | > > ^ | v |
> + + + +---+---+---+ +---+---+ +
> | | | > > > > ^ | | v |
> + +---+---+---+---+---+---+ +---+ +
> | | | | v < < |
> + + + + + + +---+ +---+---+
> | | | | | | v < | |
> + + +---+---+ +---+ +---+ +---+
> | | | | v < | |
> + +---+ + + + +---+---+---+ +
> | | | > > > > e |
> +---+---+---+---+---+---+---+---+---+---+
Copyright 2012 Abhinav Sarkar \<abhinav\@abhinavsarkar.net\>
-} -}
{-# LANGUAGE BangPatterns, TupleSections #-} {-# LANGUAGE BangPatterns, TupleSections #-}
module AmazingMazes (Cell(..), Maze(..), MazeSolution(..), module AmazingMazes (Cell(..), Maze(..), MazeSolution(..),
@ -87,23 +89,23 @@ randomShuffle list = do
-- maze -- -- maze --
-- a cell with x and y coordinates -- | A cell with x and y coordinates
type Cell = (Int, Int) type Cell = (Int, Int)
-- a maze with width, height and a map of cell paths -- | A maze with width, height and a map of cell paths
data Maze = Maze Int Int (M.Map Cell [Cell]) data Maze = Maze Int Int (M.Map Cell [Cell])
-- a solution to a maze with the start and end cells and the path map -- | A solution to a maze with the start and end cells and the path map
data MazeSolution = MazeSolution Cell Cell (M.Map Cell Cell) data MazeSolution = MazeSolution Cell Cell (M.Map Cell Cell)
-- get the neighbour cells -- | Gets the neighbour cells
nextCells :: Int -> Int -> Cell -> [Cell] nextCells :: Int -> Int -> Cell -> [Cell]
nextCells width height (x, y) = nextCells width height (x, y) =
filter (\(x', y') -> and [x' >= 0, x' < width, y' >= 0, y' < height]) filter (\(x', y') -> and [x' >= 0, x' < width, y' >= 0, y' < height])
. map (\(xd, yd) -> (x + xd, y + yd)) . map (\(xd, yd) -> (x + xd, y + yd))
$ [(0,-1), (1,0), (0,1), (-1,0)] $ [(0,-1), (1,0), (0,1), (-1,0)]
-- generate a random maze given the start cell and an empty maze -- | Generates a random maze given the start cell and an empty maze
generateMaze_ :: Cell -> Maze -> RandomState Maze generateMaze_ :: Cell -> Maze -> RandomState Maze
generateMaze_ start maze@(Maze width height cellMap) = do generateMaze_ start maze@(Maze width height cellMap) = do
!next <- randomShuffle . filter (not . flip M.member cellMap) $ nextCells width height start !next <- randomShuffle . filter (not . flip M.member cellMap) $ nextCells width height start
@ -118,26 +120,28 @@ generateMaze_ start maze@(Maze width height cellMap) = do
else return mz) else return mz)
maze next maze next
-- generate a random maze given the maze width and height using recursive backtracking -- | Generates a random maze given the maze width and height using recursive backtracking
generateMaze :: Int -> Int -> RandomState Maze generateMaze :: Int -- ^ Maze width
-> Int -- ^ Maze height
-> State StdGen Maze -- ^ The generated maze inside a 'State' monad with a random generator
generateMaze width height = do generateMaze width height = do
x <- getRandomR (0, width - 1) x <- getRandomR (0, width - 1)
y <- getRandomR (0, height - 1) y <- getRandomR (0, height - 1)
generateMaze_ (x, y) (Maze width height M.empty) generateMaze_ (x, y) (Maze width height M.empty)
-- render a maze and its solution as a string -- | Renders a maze and its solution as a string
renderMaze :: Maze -> MazeSolution -> String renderMaze :: Maze -> MazeSolution -> String
renderMaze maze@(Maze width height _) solution = renderMaze maze@(Maze width height _) solution =
concatMap (renderMazeRow maze solution) [0 .. (height - 1)] concatMap (renderMazeRow maze solution) [0 .. (height - 1)]
++ concat (replicate width "+---") ++ "+" ++ concat (replicate width "+---") ++ "+"
-- render a row of a maze and the maze's solution as a string -- | Renders a row of a maze and the maze's solution as a string
renderMazeRow :: Maze -> MazeSolution -> Int -> String renderMazeRow :: Maze -> MazeSolution -> Int -> String
renderMazeRow maze@(Maze width height _) solution rowIx = renderMazeRow maze@(Maze width height _) solution rowIx =
let (up, side) = unzip . map (renderMazeCell maze solution rowIx) $ [0 .. (width - 1)] let (up, side) = unzip . map (renderMazeCell maze solution rowIx) $ [0 .. (width - 1)]
in concat up ++ "+" ++ "\n" ++ concat side ++ "|" ++ "\n" in concat up ++ "+" ++ "\n" ++ concat side ++ "|" ++ "\n"
-- render a cell of a maze and the maze's solution as a pair of strings -- | Renders a cell of a maze and the maze's solution as a pair of strings
renderMazeCell :: Maze -> MazeSolution -> Int -> Int -> (String, String) renderMazeCell :: Maze -> MazeSolution -> Int -> Int -> (String, String)
renderMazeCell (Maze _ _ cellMap) (MazeSolution start end solution) rowIx colIx = let renderMazeCell (Maze _ _ cellMap) (MazeSolution start end solution) rowIx colIx = let
cell = (colIx, rowIx) cell = (colIx, rowIx)
@ -155,12 +159,15 @@ renderMazeCell (Maze _ _ cellMap) (MazeSolution start end solution) rowIx colIx
Nothing -> " " Nothing -> " "
Just (x', y') -> fromMaybe " " $ M.lookup (x' - x, y' - y) marks Just (x', y') -> fromMaybe " " $ M.lookup (x' - x, y' - y) marks
-- symbols to mark the solution path -- | Symbols to mark the solution path
marks = M.fromList [((0,-1), "^"), ((1,0), ">"), ((0,1), "v"), ((-1,0), "<")] marks = M.fromList [((0,-1), "^"), ((1,0), ">"), ((0,1), "v"), ((-1,0), "<")]
-- solve the maze using A* given the maze and the start and end cells using -- | Solves the maze using A* given the maze and the start and end cells using
-- Manhattan distance as the heuristic -- Manhattan distance as the heuristic
solveMaze :: Maze -> Cell -> Cell -> MazeSolution solveMaze :: Maze -- ^ The maze to solve
-> Cell -- ^ The start cell
-> Cell -- ^ The end cell
-> MazeSolution -- ^ The solution of the maze
solveMaze maze@(Maze _ _ cellMap) start end = solveMaze maze@(Maze _ _ cellMap) start end =
MazeSolution start end MazeSolution start end
. M.fromList . M.fromList
@ -171,6 +178,9 @@ solveMaze maze@(Maze _ _ cellMap) start end =
. astar start end (map (,1) . fromMaybe [] . flip M.lookup cellMap) . astar start end (map (,1) . fromMaybe [] . flip M.lookup cellMap)
$ (\(x, y) (x', y') -> abs (x - x') + abs (y - y')) $ (\(x, y) (x', y') -> abs (x - x') + abs (y - y'))
-- | Reads the width, height, start and end cell co-ordinates from command
-- line arguments, generates a maze using them, solves it and renders it
-- with the solution.
main = do main = do
(width : height : sx : sy : ex : ey : _) <- fmap (map read) getArgs (width : height : sx : sy : ex : ey : _) <- fmap (map read) getArgs
g <- newStdGen g <- newStdGen

50
BarrelOfMonkeys.hs
View File

@ -1,7 +1,16 @@
{- {-|
A solution to rubyquiz 30 (http://rubyquiz.com/quiz30.html). A solution to rubyquiz 30 (http://rubyquiz.com/quiz30.html).
Copyright 2012 Abhinav Sarkar <abhinav@abhinavsarkar.net> /A "Barrel of Monkeys" playlist is when the next song in the playlist begins/
/with the same letter as the current song ended in./
/Given any starting and ending song, create a playlist that connects the two songs./
/Create playlists of specific durations and shortest and longest playlists by/
/the number of songs and the total duration./
/The song data is available at/ <http://rubyquiz.com/SongLibrary.xml.gz>.
Copyright 2012 Abhinav Sarkar \<abhinav\@abhinavsarkar.net\>
-} -}
{-# LANGUAGE Arrows, NoMonomorphismRestriction, RecordWildCards #-} {-# LANGUAGE Arrows, NoMonomorphismRestriction, RecordWildCards #-}
@ -30,11 +39,12 @@ import Text.XML.HXT.Core hiding ((:->), when)
--- types --- --- types ---
-- | A song with all the fields
data Song = Song { data Song = Song {
songArtist :: T.Text, songArtist :: T.Text, -- ^ The song artist
songId :: Int, songId :: Int, -- ^ The song ID
songName :: T.Text, songName :: T.Text, -- ^ The song name
songDuration :: Int songDuration :: Int -- ^ The song duration in milliseconds
} }
instance Eq Song where instance Eq Song where
@ -47,13 +57,18 @@ instance Show Song where
show (Song {..}) = printf "%s. %s - %s (%sms)" show (Song {..}) = printf "%s. %s - %s (%sms)"
(show songId) (T.unpack songArtist) (T.unpack songName) (show songDuration) (show songId) (T.unpack songArtist) (T.unpack songName) (show songDuration)
-- | The whole song library
data SongLibrary = SongLibrary { data SongLibrary = SongLibrary {
songIdMap :: M.Map Int Song, songIdMap :: M.Map Int Song,
fstCharMap :: M.Map Char [Song], fstCharMap :: M.Map Char [Song],
lstCharMap :: M.Map Char [Song] lstCharMap :: M.Map Char [Song]
} }
data Playlist = Playlist { playlistSongs :: [Song], playlistDuration :: Int } -- | A playlist of songs
data Playlist = Playlist {
playlistSongs :: [Song], -- ^ The songs in the playlist
playlistDuration :: Int -- ^ The total duration of the playlist in milliseconds
}
--- XML parsing --- --- XML parsing ---
@ -72,6 +87,7 @@ getSongs = atTag "Artist" >>>
songs <- listA getSong -< a songs <- listA getSong -< a
returnA -< map (uncurry3 $ Song sArtist) songs returnA -< map (uncurry3 $ Song sArtist) songs
-- | Reads the song library from the XML file given its path
getSongsFromXml :: FilePath -> IO SongLibrary getSongsFromXml :: FilePath -> IO SongLibrary
getSongsFromXml file = getSongsFromXml file =
fmap (uncurry3 SongLibrary fmap (uncurry3 SongLibrary
@ -104,8 +120,13 @@ playlist library nextSong startId endId = do
let pl = concatMap snd . maybeToList . astar start end nextSong $ (\_ _ -> 0) let pl = concatMap snd . maybeToList . astar start end nextSong $ (\_ _ -> 0)
return $ Playlist pl (playlistTime pl) return $ Playlist pl (playlistTime pl)
-- | Creates the shortest and longest playlist by the number of song and
-- the shortest and longest playlist by the length of the playlist
shortestPlaylist, longestPlaylist, shortestTimePlaylist, longestTimePlaylist shortestPlaylist, longestPlaylist, shortestTimePlaylist, longestTimePlaylist
:: SongLibrary -> Int -> Int -> Maybe Playlist :: SongLibrary -- ^ The song library
-> Int -- ^ The start song ID
-> Int -- ^ The end song ID
-> Maybe Playlist -- ^ (@Just@ resultant playlist) if it exists else @Nothing@
shortestPlaylist library = shortestPlaylist library =
playlist library (\song -> map (\s -> (s, 1)) . nextSongs song $ library) playlist library (\song -> map (\s -> (s, 1)) . nextSongs song $ library)
@ -156,7 +177,16 @@ playlistTimes library startId endId = let
(distances, queue') prev (distances, queue') prev
in loop distances' queue'' in loop distances' queue''
timedPlaylist :: SongLibrary -> Int -> Int -> Int -> Int -> Maybe Playlist -- | Creates a playlist with its duration as close a possible to the given duration
timedPlaylist ::
SongLibrary -- ^ The song library
-> Int -- ^ The required duration in milliseconds
-> Int -- ^ The start song ID
-> Int -- ^ The end song ID
-> Int -- ^ Maximum number of child nodes to consider while
-- traversing the graph to create the playlist. Used for
-- tuning the runtime of the function
-> Maybe Playlist -- ^ (@Just@ resultant playlist) if it exists else @Nothing@
timedPlaylist library time startId endId maxChild = timedPlaylist library time startId endId maxChild =
fst $ timedPlaylist_ library time startId endId S.empty M.empty fst $ timedPlaylist_ library time startId endId S.empty M.empty
(playlistTimes library startId endId) maxChild (playlistTimes library startId endId) maxChild

83
Cryptograms.hs
View File

@ -1,14 +1,26 @@
{- {-|
Decrypts a cryptogram (a substitution cypher). A solution to rubyquiz 13 (<http://rubyquiz.com/quiz13.html>).
A solution to rubyquiz 13 (http://rubyquiz.com/quiz13.html).
Usage: ./Cryptograms dictionary_file encrypted_file num_max_mappings
Copyright 2012 Abhinav Sarkar <abhinav@abhinavsarkar.net> Decrypts a cryptogram (a substitution cypher).
The decryption mapping is created by finding the words from the dictionary which have
the same form as the given token to translates, using the words to create partial
mappings and then merging these partial mappings to get more complete mappings.
Similarly, the partial mappings for all tokens are merged together to get the
complete mapping. The mappings are scored by how many tokens they are able to
translated successfully into dictionary words.
Usage:
> ./Cryptograms <dictionary_file> <encrypted_file> <num_max_mappings>
Copyright 2012 Abhinav Sarkar \<abhinav\@abhinavsarkar.net\>
-} -}
{-# LANGUAGE BangPatterns #-} {-# LANGUAGE BangPatterns #-}
module Cryptograms (Mapping, Dict, readDict, translateToken, module Cryptograms (Mapping, Token, Dict, readDict, translateToken,
scoreMapping, findBestMappings, showMapping, main) scoreMapping, findBestMappings, showMapping, main)
where where
@ -26,11 +38,16 @@ import Text.Printf (printf)
trace :: String -> a -> a trace :: String -> a -> a
trace _ x = x trace _ x = x
-- | A mapping between two alphabets.
type Mapping = M.Map Char Char type Mapping = M.Map Char Char
-- | An encrypted token.
type Token = String
-- | The dictionary of words.
newtype Dict = Dict (M.Map Int (S.Set String)) newtype Dict = Dict (M.Map Int (S.Set String))
-- reads the dictionary from the given file. must contain one word per line. -- | Reads the dictionary from the given file. Must contain one word per line.
readDict :: FilePath -> IO Dict readDict :: FilePath -> IO Dict
readDict filePath = do readDict filePath = do
!dictWords <- fmap (filter (all isAlpha) . map (map toLower) . lines) !dictWords <- fmap (filter (all isAlpha) . map (map toLower) . lines)
@ -39,40 +56,46 @@ readDict filePath = do
foldl' (\dict w -> M.insertWith S.union (length w) (S.singleton w) dict) foldl' (\dict w -> M.insertWith S.union (length w) (S.singleton w) dict)
M.empty dictWords M.empty dictWords
-- translates the token using the given mapping. -- | Translates the token using the given mapping.
-- return Nothing if unable to translate. -- Returns @Nothing@ if unable to translate.
translateToken :: Mapping -> String -> Maybe String translateToken :: Mapping -> Token -> Maybe String
translateToken mapping = fmap reverse translateToken mapping = fmap reverse
. foldM (\acc char -> M.lookup char mapping >>= Just . (:acc)) "" . foldM (\acc char -> M.lookup char mapping >>= Just . (:acc)) ""
-- translates all tokens using the given mapping. -- Translates all tokens using the given mapping.
-- translates the token to '---' if unable to translate. -- Translates the token to '---' if unable to translate.
translateTokens :: Mapping -> [String] -> [String] translateTokens :: Mapping -> [Token] -> [String]
translateTokens mapping = translateTokens mapping =
map (\token -> map (\token ->
fromMaybe (replicate (length token ) '-') . translateToken mapping $ token) fromMaybe (replicate (length token ) '-') . translateToken mapping $ token)
-- checks if the given word is in the dictionary. -- Checks if the given word is in the dictionary.
inDict :: Dict -> String -> Bool inDict :: Dict -> String -> Bool
inDict (Dict dict) word = inDict (Dict dict) word =
case M.lookup (length word) dict of case M.lookup (length word) dict of
Nothing -> False Nothing -> False
Just ws -> word `S.member` ws Just ws -> word `S.member` ws
-- scores a mapping by counting the number of translated tokens that are -- | Scores a mapping by counting the number of translated tokens that are
-- in the dictionary. -- in the dictionary.
scoreMapping :: Dict -> Mapping -> [String] -> Int scoreMapping :: Dict -- ^ The dictionary
-> Mapping -- ^ The mapping to score
-> [Token] -- ^ The tokens to translate
-> Int -- ^ The score of the mapping
scoreMapping dict mapping = scoreMapping dict mapping =
length . filter (inDict dict) . mapMaybe (translateToken mapping) length . filter (inDict dict) . mapMaybe (translateToken mapping)
-- scores multiple mappings and returns an assoc list sorted by descending score. -- Scores multiple mappings and returns an assoc list sorted by descending score.
scoreMappings :: Dict -> [String] -> [Mapping] -> [(Mapping, Int)] scoreMappings :: Dict -> [Token] -> [Mapping] -> [(Mapping, Int)]
scoreMappings dict tokens = scoreMappings dict tokens =
reverse . sortBy (comparing snd) reverse . sortBy (comparing snd)
. map (\mapping -> (mapping, scoreMapping dict mapping tokens)) . map (\mapping -> (mapping, scoreMapping dict mapping tokens))
-- finds maximum num mappings which have best scores for the given tokens. -- | Finds n best mappings which have best scores for the given tokens.
findBestMappings :: Dict -> Int -> [String] -> [Mapping] findBestMappings :: Dict -- ^ The dictionary
-> Int -- ^ Maximum number of mappings to consider
-> [Token] -- ^ The tokens to translate
-> [Mapping] -- ^ The mappings with best scores
findBestMappings dict num tokens = let findBestMappings dict num tokens = let
mappings = scoreMappings dict tokens mappings = scoreMappings dict tokens
. S.toList . S.toList
@ -86,8 +109,8 @@ findBestMappings dict num tokens = let
maxScore = if not (null mappings) then snd . head $ mappings else 0 maxScore = if not (null mappings) then snd . head $ mappings else 0
in map fst . takeWhile ((== maxScore) . snd) $ mappings in map fst . takeWhile ((== maxScore) . snd) $ mappings
-- finds the merged mappings for a token -- Finds the merged mappings for a token
findMappingsForToken :: Dict -> S.Set Mapping -> String -> S.Set Mapping findMappingsForToken :: Dict -> S.Set Mapping -> Token -> S.Set Mapping
findMappingsForToken dict mappings token = findMappingsForToken dict mappings token =
case find (inDict dict) . mapMaybe (flip translateToken token) case find (inDict dict) . mapMaybe (flip translateToken token)
. reverse . sortBy (comparing M.size) . reverse . sortBy (comparing M.size)
@ -99,7 +122,7 @@ findMappingsForToken dict mappings token =
-- with the mappings for the token. -- with the mappings for the token.
Nothing -> mergeMappingLists mappings (createMappingsForToken dict token) Nothing -> mergeMappingLists mappings (createMappingsForToken dict token)
-- merges mapping lists. discards conflicting mappings while merging. -- Merges mapping lists. discards conflicting mappings while merging.
mergeMappingLists :: S.Set Mapping -> S.Set Mapping -> S.Set Mapping mergeMappingLists :: S.Set Mapping -> S.Set Mapping -> S.Set Mapping
mergeMappingLists mappings1 mappings2 mergeMappingLists mappings1 mappings2
| mappings1 == S.empty = mappings2 | mappings1 == S.empty = mappings2
@ -113,7 +136,7 @@ mergeMappingLists mappings1 mappings2
[mergeMappings m1 m2 | m1 <- S.toList mappings1, m2 <- S.toList mappings2]] [mergeMappings m1 m2 | m1 <- S.toList mappings1, m2 <- S.toList mappings2]]
in trace (printf "Merged to %s mappings" (show $ S.size merged)) merged in trace (printf "Merged to %s mappings" (show $ S.size merged)) merged
-- merges two mappings. returns Nothing if mappings conflict. -- Merges two mappings. returns Nothing if mappings conflict.
mergeMappings :: Mapping -> Mapping -> Maybe Mapping mergeMappings :: Mapping -> Mapping -> Maybe Mapping
mergeMappings mapping1 mapping2 = mergeMappings mapping1 mapping2 =
foldM foldM
@ -123,8 +146,8 @@ mergeMappings mapping1 mapping2 =
else Just $ M.insert k v acc) else Just $ M.insert k v acc)
mapping1 $ M.toList mapping2 mapping1 $ M.toList mapping2
-- creates mappings for a token by finding words of same form from the dictionary. -- Creates mappings for a token by finding words of same form from the dictionary.
createMappingsForToken :: Dict -> String -> S.Set Mapping createMappingsForToken :: Dict -> Token -> S.Set Mapping
createMappingsForToken (Dict dict) token = createMappingsForToken (Dict dict) token =
case M.lookup (length token) dict of case M.lookup (length token) dict of
Nothing -> S.empty Nothing -> S.empty
@ -134,9 +157,9 @@ createMappingsForToken (Dict dict) token =
. filter ((== tokenF) . tokenForm) . S.toList $ words . filter ((== tokenF) . tokenForm) . S.toList $ words
in trace (printf "%s -> %s matches" token (show . S.size $ matches)) matches in trace (printf "%s -> %s matches" token (show . S.size $ matches)) matches
-- returns form of a token. for example, the form of "abc" is [1,2,3] -- Returns form of a token. for example, the form of "abc" is [1,2,3]
-- while the form of "aba" is [1,2,1]. -- while the form of "aba" is [1,2,1].
tokenForm :: String -> [Int] tokenForm :: Token -> [Int]
tokenForm token = let tokenForm token = let
(_, form, _) = (_, form, _) =
foldl' (\(formMap, form, lf) char -> foldl' (\(formMap, form, lf) char ->
@ -146,11 +169,11 @@ tokenForm token = let
(M.empty, [], 0) token (M.empty, [], 0) token
in reverse form in reverse form
-- creates the mapping between two strings of same length. -- Creates the mapping between two strings of same length.
getMapping :: String -> String -> Mapping getMapping :: String -> String -> Mapping
getMapping t1 t2 = M.fromList $ zip t1 t2 getMapping t1 t2 = M.fromList $ zip t1 t2
-- returns text representation of a mapping. -- | Returns text representation of a mapping.
showMapping :: Mapping -> String showMapping :: Mapping -> String
showMapping mapping = showMapping mapping =
map snd . sortBy (comparing fst) . M.toList map snd . sortBy (comparing fst) . M.toList

51
DiceRoller.hs
View File

@ -1,22 +1,24 @@
{- {-|
A solution to rubyquiz 61 (http://rubyquiz.com/quiz61.html). A solution to rubyquiz 61 (<http://rubyquiz.com/quiz61.html>).
The task for this Quiz is to write a dice roller. The program should take /The task for this Quiz is to write a dice roller. The program should take/
two arguments: a dice expression followed by the number of times to roll it /two arguments: a dice expression followed by the number of times to roll it/
(being optional, with a default of 1). /(being optional, with a default of 1)./
The solution is done using Parsec for parsing the expression into an AST and The solution is done using 'Parsec' for parsing the expression into an AST and
then evaluating it recursively. then evaluating it recursively.
Usage: bin/DiceRoller "(5d5-4)d(16/d4)+3" 10 Usage:
bin/DiceRoller 3d3
Copyright 2012 Abhinav Sarkar <abhinav@abhinavsarkar.net> > bin/DiceRoller "(5d5-4)d(16/d4)+3" 10
> bin/DiceRoller 3d3
Copyright 2012 Abhinav Sarkar \<abhinav\@abhinavsarkar.net\>
-} -}
{-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE NoMonomorphismRestriction #-}
module DiceRoller (RandomState, Expr(..), eval, expr, main) where module DiceRoller (Expr(..), eval, expr, main) where
import Control.Applicative ((<$>), (<*), (*>), (<|>)) import Control.Applicative ((<$>), (<*), (*>), (<|>))
import Control.Monad (foldM, liftM2, liftM, when) import Control.Monad (foldM, liftM2, liftM, when)
@ -28,9 +30,7 @@ import System.Environment (getArgs)
-- Randomness setup for dice roll -- -- Randomness setup for dice roll --
type RandomState = State StdGen getRandomR :: Random a => (a, a) -> State StdGen a
getRandomR :: Random a => (a, a) -> RandomState a
getRandomR limits = do getRandomR limits = do
gen <- get gen <- get
let (val, gen') = randomR limits gen let (val, gen') = randomR limits gen
@ -39,18 +39,19 @@ getRandomR limits = do
-- AST -- -- AST --
-- Expression AST types -- | Expression AST types
data Expr = Lit Int | -- An integer literal data Expr = Lit Int | -- ^ An integer literal
Add Expr Expr | -- Binary addition Add Expr Expr | -- ^ Binary addition
Sub Expr Expr | -- Binary subtraction Sub Expr Expr | -- ^ Binary subtraction
Mul Expr Expr | -- Binary multiplication Mul Expr Expr | -- ^ Binary multiplication
Div Expr Expr | -- Binary integer division Div Expr Expr | -- ^ Binary integer division
Rol Expr | -- Unary single dice roll Rol Expr | -- ^ Unary single dice roll
MRol Expr Expr -- Binary multiple dice rolls MRol Expr Expr -- ^ Binary multiple dice rolls
deriving (Show) deriving (Show)
-- Recursively evaluates the AST to get its value -- | Recursively evaluates the AST to its value inside a 'State' monad with
eval :: Expr -> RandomState Int -- a random generator
eval :: Expr -> State StdGen Int
eval (Lit i) = return i eval (Lit i) = return i
eval (Add e1 e2) = liftM2 (+) (eval e1) (eval e2) eval (Add e1 e2) = liftM2 (+) (eval e1) (eval e2)
eval (Sub e1 e2) = liftM2 (-) (eval e1) (eval e2) eval (Sub e1 e2) = liftM2 (-) (eval e1) (eval e2)
@ -90,12 +91,12 @@ table = [[bop 'd' MRol AssocLeft], -- multiple rolls
[bop '+' Add AssocLeft, bop '-' Sub AssocLeft]] -- addition and subtraction [bop '+' Add AssocLeft, bop '-' Sub AssocLeft]] -- addition and subtraction
where bop c f = Infix (spaced (char c) *> return f) -- binary operators where bop c f = Infix (spaced (char c) *> return f) -- binary operators
-- A parser to parse the full expression -- | A parser to parse the dice roll expression
expr = buildExpressionParser table factor expr = buildExpressionParser table factor
-- Main -- -- Main --
-- Reads the expression from program arguments, parses it and if successful, -- | Reads the expression from program arguments, parses it and if successful,
-- evaluates the AST and displays the resultant values -- evaluates the AST and displays the resultant values
main = do main = do
args <- getArgs args <- getArgs

23
EnglishNumerals.hs
View File

@ -1,10 +1,12 @@
{- {-|
A solution to rubyquiz 25 (http://rubyquiz.com/quiz25.html). A solution to rubyquiz 25 (<http://rubyquiz.com/quiz25.html>).
When the integers 1 to 10_000_000_000 are written in the English language, /When the integers 1 to 10_000_000_000 are written in the English language,/
then sorted as strings, which odd number appears first in the list? /then sorted as strings, which odd number appears first in the list?/
Usage: ./EnglishNumerals basis-file max_num Usage:
> ./EnglishNumerals <basis_file> <max_num>
Example basis file for English numerals: Example basis file for English numerals:
@ -43,7 +45,7 @@
> 2, two > 2, two
> 1, one > 1, one
Copyright 2012 Abhinav Sarkar <abhinav@abhinavsarkar.net> Copyright 2012 Abhinav Sarkar \<abhinav\@abhinavsarkar.net\>
-} -}
module EnglishNumerals (Basis, readBasis, toEnglishNumerals, firstOddByEnglishNumeral, main) module EnglishNumerals (Basis, readBasis, toEnglishNumerals, firstOddByEnglishNumeral, main)
@ -56,12 +58,13 @@ import Data.Maybe (fromMaybe)
import Data.List.Split (splitOn) import Data.List.Split (splitOn)
import System.Environment (getArgs) import System.Environment (getArgs)
-- | A basis is a list of basic numeral translations into a languages.
type Basis = [(Integer, String)] type Basis = [(Integer, String)]
isPowerOfTen :: Integer -> Bool isPowerOfTen :: Integer -> Bool
isPowerOfTen = (== "10") . nub . show isPowerOfTen = (== "10") . nub . show
-- reads the basis of the numeral system -- | Reads the basis of the numeral system
readBasis :: FilePath -> IO Basis readBasis :: FilePath -> IO Basis
readBasis = readBasis =
fmap (map (\line -> let (n:en:_) = splitOn "," line in (read n, en)) . lines) . readFile fmap (map (\line -> let (n:en:_) = splitOn "," line in (read n, en)) . lines) . readFile
@ -74,7 +77,7 @@ toEnglishNumeralsMemo basis n =
then cache basis `Seq.index` (fromIntegral n -1) then cache basis `Seq.index` (fromIntegral n -1)
else toEnglishNumerals basis n else toEnglishNumerals basis n
-- converts a number to its numeral representation in the given basis -- | Converts a number to its numeral representation in the given basis
toEnglishNumerals :: Basis -> Integer -> String toEnglishNumerals :: Basis -> Integer -> String
toEnglishNumerals basis n = toEnglishNumerals basis n =
unwords . words . go n (dropWhile ((> n) . fst) basis) $ "" unwords . words . go n (dropWhile ((> n) . fst) basis) $ ""
@ -102,8 +105,8 @@ minEnglish basis start end step =
maximumBy (flip $ comparing fst) maximumBy (flip $ comparing fst)
. map (\x -> (toEnglishNumerals basis x, x)) $ [start, start + step .. end] . map (\x -> (toEnglishNumerals basis x, x)) $ [start, start + step .. end]
-- finds the first odd number and its representation between 1 and n which is -- | Finds the first odd number and its representation between 1 and the given number
-- minimum by the lexicographically sorted representations -- which is minimum by the lexicographically sorted representations
firstOddByEnglishNumeral :: Basis -> Integer -> (String, Integer) firstOddByEnglishNumeral :: Basis -> Integer -> (String, Integer)
firstOddByEnglishNumeral basis n = firstOddByEnglishNumeral basis n =
(\(eng, en) -> (unwords . words $ eng, en)) (\(eng, en) -> (unwords . words $ eng, en))

18
GedcomParser.hs
View File

@ -1,7 +1,10 @@
-- A GEDCOM to XML converter written using Parsec as a -- | A GEDCOM to XML converter written using Parsec as a
-- solution for rubyquiz 6 (http://rubyquiz.com/quiz6.html). -- solution for rubyquiz 6 (<http://rubyquiz.com/quiz6.html>).
--
-- Example GEDCOM document at -- Example GEDCOM document at
-- http://cpansearch.perl.org/src/PJCJ/Gedcom-1.16/royal.ged -- <http://cpansearch.perl.org/src/PJCJ/Gedcom-1.16/royal.ged>
--
-- Copyright 2012 Abhinav Sarkar \<abhinav\@abhinavsarkar.net\>
{-# LANGUAGE NoMonomorphismRestriction, RecordWildCards, FlexibleContexts #-} {-# LANGUAGE NoMonomorphismRestriction, RecordWildCards, FlexibleContexts #-}
@ -18,7 +21,7 @@ data Line = Line {
lineId :: Maybe String lineId :: Maybe String
} }
-- an element in a GEDCOM document -- | An element in a GEDCOM document
data Elem = Elem { data Elem = Elem {
elemTag :: String, elemTag :: String,
elemValue :: Maybe String, elemValue :: Maybe String,
@ -26,6 +29,7 @@ data Elem = Elem {
elemChildren :: [Elem] elemChildren :: [Elem]
} deriving (Show) } deriving (Show)
-- | A GEDCOM document
type Doc = [Elem] type Doc = [Elem]
indent n = concat . replicate n $ " " indent n = concat . replicate n $ " "
@ -61,7 +65,7 @@ element level = do
children <- many (element $ level + 1) children <- many (element $ level + 1)
return $ Elem lineTag lineValue lineId children return $ Elem lineTag lineValue lineId children
-- parses a document -- | Parser to parse a GEDCOM document from a 'String'
document :: Stream s m Char => ParsecT s u m Doc document :: Stream s m Char => ParsecT s u m Doc
document = element 0 `endBy` whitespaces document = element 0 `endBy` whitespaces
@ -98,14 +102,14 @@ elemToXml indentation Elem{..} =
++ unlines (map (elemToXml (indentation + 1)) elemChildren) ++ unlines (map (elemToXml (indentation + 1)) elemChildren)
++ indent indentation ++ "</" ++ elemTag ++ ">" ++ indent indentation ++ "</" ++ elemTag ++ ">"
-- converts a document to XML -- | Converts a GEDCOM document to XML
documentToXml :: Doc -> String documentToXml :: Doc -> String
documentToXml doc = "<DOCUMENT>\n" documentToXml doc = "<DOCUMENT>\n"
++ (unlines . map (elemToXml 1) $ doc') ++ (unlines . map (elemToXml 1) $ doc')
++ "</DOCUMENT>" ++ "</DOCUMENT>"
where doc' = normalizeDoc doc where doc' = normalizeDoc doc
-- converts a GEDCOM document supplied through STDIN into XML -- | Converts a GEDCOM document supplied through STDIN into XML
-- and prints to STDOUT -- and prints to STDOUT
main = do main = do
text <- getContents text <- getContents

56
KnightsTravails.hs
View File

@ -1,27 +1,28 @@
{- {-|
A solution to rubyquiz 27 (http://rubyquiz.com/quiz27.html). A solution to rubyquiz 27 (<http://rubyquiz.com/quiz27.html>).
Given a standard 8 x 8 chessboard where each position is indicated in algebraic /Given a standard 8 x 8 chessboard where each position is indicated in algebraic/
notation (with the lower left corner being a1), design a script that accepts /notation (with the lower left corner being a1), design a script that accepts/
two or more arguments. /two or more arguments./
The first argument indicates the starting position of the knight. The second /The first argument indicates the starting position of the knight. The second/
argument indicates the ending position of the knight. Any additional arguments /argument indicates the ending position of the knight. Any additional arguments/
indicate positions that are forbidden to the knight. /indicate positions that are forbidden to the knight./
Return an array indicating the shortest path that the knight must travel to /Return an array indicating the shortest path that the knight must travel to/
get to the end position without landing on one of the forbidden squares. /get to the end position without landing on one of the forbidden squares./
If there is no valid path to the destination return nil. /If there is no valid path to the destination return nil./
Usage: ./KnightsTravails start_pos target_pos [blocked_pos]* Usage:
Copyright 2012 Abhinav Sarkar <abhinav@abhinavsarkar.net> > ./KnightsTravails start_pos target_pos [blocked_pos]*
Copyright 2012 Abhinav Sarkar \<abhinav\@abhinavsarkar.net\>
-} -}
{-# LANGUAGE MultiParamTypeClasses, RecordWildCards #-} {-# LANGUAGE MultiParamTypeClasses, RecordWildCards #-}
module KnightsTravails (Square, Board(..), fromNotation, toNotation, isValidNotation, module KnightsTravails (Square, fromNotation, toNotation, isValidNotation, search, main)
bfsSearch, astarSearch, main)
where where
import qualified Data.Set as S import qualified Data.Set as S
@ -31,22 +32,22 @@ import Data.Maybe (fromJust)
import Control.Arrow (second) import Control.Arrow (second)
import System.Environment (getArgs) import System.Environment (getArgs)
-- A square on the chess board -- | A square on the chess board
type Square = (Int, Int) type Square = (Int, Int)
-- A chess board with the knight's current position and a set of blocked squares -- A chess board with the knight's current position and a set of blocked squares
data Board = Board { knightPos :: Square, blockedSquares :: S.Set Square } data Board = Board { knightPos :: Square, blockedSquares :: S.Set Square }
deriving (Ord, Eq) deriving (Ord, Eq)
-- Converts a string in chess notation to a square. eg. a1 -> (1,1) -- | Converts a string in chess notation to a square. eg. a1 -> (1,1)
fromNotation :: String -> Square fromNotation :: String -> Square
fromNotation (x : y) = (fromJust (x `elemIndex` ['a'..'h']) + 1, read y) fromNotation (x : y) = (fromJust (x `elemIndex` ['a'..'h']) + 1, read y)
-- Converts a square to a string in chess notation. eg. (1,1) -> a1 -- | Converts a square to a string in chess notation. eg. (1,1) -> a1
toNotation :: Square -> String toNotation :: Square -> String
toNotation (x, y) = ((['a'..'h'] !! (x - 1)) : "") ++ show y toNotation (x, y) = ((['a'..'h'] !! (x - 1)) : "") ++ show y
-- Checks if a string is a valid chess notation -- | Checks if a string is a valid chess notation
isValidNotation notation = isValidNotation notation =
and [length notation == 2, and [length notation == 2,
head notation `elem` ['a'..'h'], head notation `elem` ['a'..'h'],
@ -71,14 +72,13 @@ knightAstar heuristic blockedSquares start target =
$ astar (Board start blockedSquares) (Board target blockedSquares) $ astar (Board start blockedSquares) (Board target blockedSquares)
nextKnightPos heuristic nextKnightPos heuristic
-- Finds a path from a start square to an end square using BFS -- | Finds a path from a start square to an end square using A* with
bfsSearch :: S.Set Square -> Square -> Square -> Maybe (Int, [Square]) -- half of the max of coordinate deltas as the heuristic function
bfsSearch = knightAstar (\_ _ -> 0) search :: S.Set Square -- ^ The set of blocked squares
-> Square -- ^ The start square
-- Finds a path from a start square to an end square using AStar with -> Square -- ^ The target square
-- half of the max of coordinate deltas as the heuristic -> Maybe (Int, [Square]) -- ^ The solution cost and path if found else 'Nothing'
astarSearch :: S.Set Square -> Square -> Square -> Maybe (Int, [Square]) search =
astarSearch =
knightAstar (\(Board (x1,y1) _) (Board (x2,y2) _) -> knightAstar (\(Board (x1,y1) _) (Board (x2,y2) _) ->
max (abs (x1-x2)) (abs (y1-y2)) `div` 2) max (abs (x1-x2)) (abs (y1-y2)) `div` 2)
@ -90,7 +90,7 @@ main = do
then error "Invalid board position" then error "Invalid board position"
else let else let
(start : target : blocked) = args (start : target : blocked) = args
in case astarSearch (S.fromList . map fromNotation $ blocked) in case search (S.fromList . map fromNotation $ blocked)
(fromNotation start) (fromNotation target) of (fromNotation start) (fromNotation target) of
Just (_, path) -> putStrLn . unwords . map toNotation $ path Just (_, path) -> putStrLn . unwords . map toNotation $ path
Nothing -> putStrLn "No path found" Nothing -> putStrLn "No path found"