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

Added Haddock documentation

Browse Source
This commit is contained in:
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.Maybe (fromJust)
-- A* algorithm: Find 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) => a -> a -> (a -> [(a, b)]) -> (a -> a -> b) -> Maybe (b, [a])
-- | A* algorithm: Finds a path from initial node to goal node using a heuristic function.
astar :: (Ord a, Ord b, Num b) =>
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' (PQ.singleton (hueristic initNode goalNode) (initNode, 0))
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
solvable for any start and end positions and there should be only one possible
solution for any pair of start and end positions.
/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/
/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
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>
Coordinates are zero based.
Usage (Coordinates are zero based):
abhinav@xj9:rubyquiz# bin/AmazingMazes 10 10 0 0 9 9
+---+---+---+---+---+---+---+---+---+---+
| s > v | | |
+---+---+ +---+ + +---+ + +---+
| v < < | | | | | |
+ +---+---+---+---+---+ + + + +
| v | | | |
+ +---+---+---+ + +---+---+---+ +
| > > > v | | | > v |
+---+---+---+ + + +---+---+ + +
| | v < | | > > ^ | v |
+ + + +---+---+---+ +---+---+ +
| | | > > > > ^ | | v |
+ +---+---+---+---+---+---+ +---+ +
| | | | v < < |
+ + + + + + +---+ +---+---+
| | | | | | v < | |
+ + +---+---+ +---+ +---+ +---+
| | | | v < | |
+ +---+ + + + +---+---+---+ +
| | | > > > > e |
+---+---+---+---+---+---+---+---+---+---+
> ./AmazingMazes <width> <height> <start_x> <start_y> <end_x> <end_y>
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 #-}
module AmazingMazes (Cell(..), Maze(..), MazeSolution(..),
@ -87,23 +89,23 @@ randomShuffle list = do
-- maze --
-- a cell with x and y coordinates
-- | A cell with x and y coordinates
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])
-- 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)
-- get the neighbour cells
-- | Gets the neighbour cells
nextCells :: Int -> Int -> Cell -> [Cell]
nextCells width height (x, y) =
filter (\(x', y') -> and [x' >= 0, x' < width, y' >= 0, y' < height])
. map (\(xd, yd) -> (x + xd, y + yd))
$ [(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_ start maze@(Maze width height cellMap) = do
!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)
maze next
-- generate a random maze given the maze width and height using recursive backtracking
generateMaze :: Int -> Int -> RandomState Maze
-- | Generates a random maze given the maze width and height using recursive backtracking
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
x <- getRandomR (0, width - 1)
y <- getRandomR (0, height - 1)
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@(Maze width height _) solution =
concatMap (renderMazeRow maze solution) [0 .. (height - 1)]
++ 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@(Maze width height _) solution rowIx =
let (up, side) = unzip . map (renderMazeCell maze solution rowIx) $ [0 .. (width - 1)]
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 _ _ cellMap) (MazeSolution start end solution) rowIx colIx = let
cell = (colIx, rowIx)
@ -155,12 +159,15 @@ renderMazeCell (Maze _ _ cellMap) (MazeSolution start end solution) rowIx colIx
Nothing -> " "
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), "<")]
-- 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
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 =
MazeSolution start end
. M.fromList
@ -171,6 +178,9 @@ solveMaze maze@(Maze _ _ cellMap) start end =
. astar start end (map (,1) . fromMaybe [] . flip M.lookup cellMap)
$ (\(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
(width : height : sx : sy : ex : ey : _) <- fmap (map read) getArgs
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 #-}
@ -30,11 +39,12 @@ import Text.XML.HXT.Core hiding ((:->), when)
--- types ---
-- | A song with all the fields
data Song = Song {
songArtist :: T.Text,
songId :: Int,
songName :: T.Text,
songDuration :: Int
songArtist :: T.Text, -- ^ The song artist
songId :: Int, -- ^ The song ID
songName :: T.Text, -- ^ The song name
songDuration :: Int -- ^ The song duration in milliseconds
}
instance Eq Song where
@ -47,13 +57,18 @@ instance Show Song where
show (Song {..}) = printf "%s. %s - %s (%sms)"
(show songId) (T.unpack songArtist) (T.unpack songName) (show songDuration)
-- | The whole song library
data SongLibrary = SongLibrary {
songIdMap :: M.Map Int Song,
fstCharMap :: 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 ---
@ -72,6 +87,7 @@ getSongs = atTag "Artist" >>>
songs <- listA getSong -< a
returnA -< map (uncurry3 $ Song sArtist) songs
-- | Reads the song library from the XML file given its path
getSongsFromXml :: FilePath -> IO SongLibrary
getSongsFromXml file =
fmap (uncurry3 SongLibrary
@ -104,8 +120,13 @@ playlist library nextSong startId endId = do
let pl = concatMap snd . maybeToList . astar start end nextSong $ (\_ _ -> 0)
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
:: 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 =
playlist library (\song -> map (\s -> (s, 1)) . nextSongs song $ library)
@ -156,7 +177,16 @@ playlistTimes library startId endId = let
(distances, queue') prev
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 =
fst $ timedPlaylist_ library time startId endId S.empty M.empty
(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).
Usage: ./Cryptograms dictionary_file encrypted_file num_max_mappings
{-|
A solution to rubyquiz 13 (<http://rubyquiz.com/quiz13.html>).
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 #-}
module Cryptograms (Mapping, Dict, readDict, translateToken,
module Cryptograms (Mapping, Token, Dict, readDict, translateToken,
scoreMapping, findBestMappings, showMapping, main)
where
@ -26,11 +38,16 @@ import Text.Printf (printf)
trace :: String -> a -> a
trace _ x = x
-- | A mapping between two alphabets.
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))
-- 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 = do
!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)
M.empty dictWords
-- translates the token using the given mapping.
-- return Nothing if unable to translate.
translateToken :: Mapping -> String -> Maybe String
-- | Translates the token using the given mapping.
-- Returns @Nothing@ if unable to translate.
translateToken :: Mapping -> Token -> Maybe String
translateToken mapping = fmap reverse
. foldM (\acc char -> M.lookup char mapping >>= Just . (:acc)) ""
-- translates all tokens using the given mapping.
-- translates the token to '---' if unable to translate.
translateTokens :: Mapping -> [String] -> [String]
-- Translates all tokens using the given mapping.
-- Translates the token to '---' if unable to translate.
translateTokens :: Mapping -> [Token] -> [String]
translateTokens mapping =
map (\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 dict) word =
case M.lookup (length word) dict of
Nothing -> False
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.
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 =
length . filter (inDict dict) . mapMaybe (translateToken mapping)
-- scores multiple mappings and returns an assoc list sorted by descending score.
scoreMappings :: Dict -> [String] -> [Mapping] -> [(Mapping, Int)]
-- Scores multiple mappings and returns an assoc list sorted by descending score.
scoreMappings :: Dict -> [Token] -> [Mapping] -> [(Mapping, Int)]
scoreMappings dict tokens =
reverse . sortBy (comparing snd)
. map (\mapping -> (mapping, scoreMapping dict mapping tokens))
-- finds maximum num mappings which have best scores for the given tokens.
findBestMappings :: Dict -> Int -> [String] -> [Mapping]
-- | Finds n best mappings which have best scores for the given tokens.
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
mappings = scoreMappings dict tokens
. S.toList
@ -86,8 +109,8 @@ findBestMappings dict num tokens = let
maxScore = if not (null mappings) then snd . head $ mappings else 0
in map fst . takeWhile ((== maxScore) . snd) $ mappings
-- finds the merged mappings for a token
findMappingsForToken :: Dict -> S.Set Mapping -> String -> S.Set Mapping
-- Finds the merged mappings for a token
findMappingsForToken :: Dict -> S.Set Mapping -> Token -> S.Set Mapping
findMappingsForToken dict mappings token =
case find (inDict dict) . mapMaybe (flip translateToken token)
. reverse . sortBy (comparing M.size)
@ -99,7 +122,7 @@ findMappingsForToken dict mappings token =
-- with the mappings for the 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 mappings1 mappings2
| mappings1 == S.empty = mappings2
@ -113,7 +136,7 @@ mergeMappingLists mappings1 mappings2
[mergeMappings m1 m2 | m1 <- S.toList mappings1, m2 <- S.toList mappings2]]
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 mapping1 mapping2 =
foldM
@ -123,8 +146,8 @@ mergeMappings mapping1 mapping2 =
else Just $ M.insert k v acc)
mapping1 $ M.toList mapping2
-- creates mappings for a token by finding words of same form from the dictionary.
createMappingsForToken :: Dict -> String -> S.Set Mapping
-- Creates mappings for a token by finding words of same form from the dictionary.
createMappingsForToken :: Dict -> Token -> S.Set Mapping
createMappingsForToken (Dict dict) token =
case M.lookup (length token) dict of
Nothing -> S.empty
@ -134,9 +157,9 @@ createMappingsForToken (Dict dict) token =
. filter ((== tokenF) . tokenForm) . S.toList $ words
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].
tokenForm :: String -> [Int]
tokenForm :: Token -> [Int]
tokenForm token = let
(_, form, _) =
foldl' (\(formMap, form, lf) char ->
@ -146,11 +169,11 @@ tokenForm token = let
(M.empty, [], 0) token
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 t1 t2 = M.fromList $ zip t1 t2
-- returns text representation of a mapping.
-- | Returns text representation of a mapping.
showMapping :: Mapping -> String
showMapping mapping =
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
two arguments: a dice expression followed by the number of times to roll it
(being optional, with a default of 1).
/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/
/(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.
Usage: bin/DiceRoller "(5d5-4)d(16/d4)+3" 10
bin/DiceRoller 3d3
Usage:
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 #-}
module DiceRoller (RandomState, Expr(..), eval, expr, main) where
module DiceRoller (Expr(..), eval, expr, main) where
import Control.Applicative ((<$>), (<*), (*>), (<|>))
import Control.Monad (foldM, liftM2, liftM, when)
@ -28,9 +30,7 @@ import System.Environment (getArgs)
-- Randomness setup for dice roll --
type RandomState = State StdGen
getRandomR :: Random a => (a, a) -> RandomState a
getRandomR :: Random a => (a, a) -> State StdGen a
getRandomR limits = do
gen <- get
let (val, gen') = randomR limits gen
@ -39,18 +39,19 @@ getRandomR limits = do
-- AST --
-- Expression AST types
data Expr = Lit Int | -- An integer literal
Add Expr Expr | -- Binary addition
Sub Expr Expr | -- Binary subtraction
Mul Expr Expr | -- Binary multiplication
Div Expr Expr | -- Binary integer division
Rol Expr | -- Unary single dice roll
MRol Expr Expr -- Binary multiple dice rolls
-- | Expression AST types
data Expr = Lit Int | -- ^ An integer literal
Add Expr Expr | -- ^ Binary addition
Sub Expr Expr | -- ^ Binary subtraction
Mul Expr Expr | -- ^ Binary multiplication
Div Expr Expr | -- ^ Binary integer division
Rol Expr | -- ^ Unary single dice roll
MRol Expr Expr -- ^ Binary multiple dice rolls
deriving (Show)
-- Recursively evaluates the AST to get its value
eval :: Expr -> RandomState Int
-- | Recursively evaluates the AST to its value inside a 'State' monad with
-- a random generator
eval :: Expr -> State StdGen Int
eval (Lit i) = return i
eval (Add 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
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
-- 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
main = do
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,
then sorted as strings, which odd number appears first in the list?
/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?/
Usage: ./EnglishNumerals basis-file max_num
Usage:
> ./EnglishNumerals <basis_file> <max_num>
Example basis file for English numerals:
@ -43,7 +45,7 @@
> 2, two
> 1, one
Copyright 2012 Abhinav Sarkar <abhinav@abhinavsarkar.net>
Copyright 2012 Abhinav Sarkar \<abhinav\@abhinavsarkar.net\>
-}
module EnglishNumerals (Basis, readBasis, toEnglishNumerals, firstOddByEnglishNumeral, main)
@ -56,12 +58,13 @@ import Data.Maybe (fromMaybe)
import Data.List.Split (splitOn)
import System.Environment (getArgs)
-- | A basis is a list of basic numeral translations into a languages.
type Basis = [(Integer, String)]
isPowerOfTen :: Integer -> Bool
isPowerOfTen = (== "10") . nub . show
-- reads the basis of the numeral system
-- | Reads the basis of the numeral system
readBasis :: FilePath -> IO Basis
readBasis =
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)
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 n =
unwords . words . go n (dropWhile ((> n) . fst) basis) $ ""
@ -102,8 +105,8 @@ minEnglish basis start end step =
maximumBy (flip $ comparing fst)
. map (\x -> (toEnglishNumerals basis x, x)) $ [start, start + step .. end]
-- finds the first odd number and its representation between 1 and n which is
-- minimum by the lexicographically sorted representations
-- | Finds the first odd number and its representation between 1 and the given number
-- which is minimum by the lexicographically sorted representations
firstOddByEnglishNumeral :: Basis -> Integer -> (String, Integer)
firstOddByEnglishNumeral basis n =
(\(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
-- solution for rubyquiz 6 (http://rubyquiz.com/quiz6.html).
-- | A GEDCOM to XML converter written using Parsec as a
-- solution for rubyquiz 6 (<http://rubyquiz.com/quiz6.html>).
--
-- 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 #-}
@ -18,7 +21,7 @@ data Line = Line {
lineId :: Maybe String
}
-- an element in a GEDCOM document
-- | An element in a GEDCOM document
data Elem = Elem {
elemTag :: String,
elemValue :: Maybe String,
@ -26,6 +29,7 @@ data Elem = Elem {
elemChildren :: [Elem]
} deriving (Show)
-- | A GEDCOM document
type Doc = [Elem]
indent n = concat . replicate n $ " "
@ -61,7 +65,7 @@ element level = do
children <- many (element $ level + 1)
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 = element 0 `endBy` whitespaces
@ -98,14 +102,14 @@ elemToXml indentation Elem{..} =
++ unlines (map (elemToXml (indentation + 1)) elemChildren)
++ indent indentation ++ "</" ++ elemTag ++ ">"
-- converts a document to XML
-- | Converts a GEDCOM document to XML
documentToXml :: Doc -> String
documentToXml doc = "<DOCUMENT>\n"
++ (unlines . map (elemToXml 1) $ doc')
++ "</DOCUMENT>"
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
main = do
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
notation (with the lower left corner being a1), design a script that accepts
two or more arguments.
/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/
/two or more arguments./
The first argument indicates the starting position of the knight. The second
argument indicates the ending position of the knight. Any additional arguments
indicate positions that are forbidden to the knight.
/The first argument indicates the starting position of the knight. The second/
/argument indicates the ending position of the knight. Any additional arguments/
/indicate positions that are forbidden to the knight./
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.
If there is no valid path to the destination return nil.
/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./
/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 #-}
module KnightsTravails (Square, Board(..), fromNotation, toNotation, isValidNotation,
bfsSearch, astarSearch, main)
module KnightsTravails (Square, fromNotation, toNotation, isValidNotation, search, main)
where
import qualified Data.Set as S
@ -31,22 +32,22 @@ import Data.Maybe (fromJust)
import Control.Arrow (second)
import System.Environment (getArgs)
-- A square on the chess board
-- | A square on the chess board
type Square = (Int, Int)
-- A chess board with the knight's current position and a set of blocked squares
data Board = Board { knightPos :: Square, blockedSquares :: S.Set Square }
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 (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 (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 =
and [length notation == 2,
head notation `elem` ['a'..'h'],
@ -71,14 +72,13 @@ knightAstar heuristic blockedSquares start target =
$ astar (Board start blockedSquares) (Board target blockedSquares)
nextKnightPos heuristic
-- Finds a path from a start square to an end square using BFS
bfsSearch :: S.Set Square -> Square -> Square -> Maybe (Int, [Square])
bfsSearch = knightAstar (\_ _ -> 0)
-- Finds a path from a start square to an end square using AStar with
-- half of the max of coordinate deltas as the heuristic
astarSearch :: S.Set Square -> Square -> Square -> Maybe (Int, [Square])
astarSearch =
-- | Finds a path from a start square to an end square using A* with
-- half of the max of coordinate deltas as the heuristic function
search :: S.Set Square -- ^ The set of blocked squares
-> Square -- ^ The start square
-> Square -- ^ The target square
-> Maybe (Int, [Square]) -- ^ The solution cost and path if found else 'Nothing'
search =
knightAstar (\(Board (x1,y1) _) (Board (x2,y2) _) ->
max (abs (x1-x2)) (abs (y1-y2)) `div` 2)
@ -90,7 +90,7 @@ main = do
then error "Invalid board position"
else let
(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
Just (_, path) -> putStrLn . unwords . map toNotation $ path
Nothing -> putStrLn "No path found"