Skip to content

Commit

Permalink
Smart constructors and refactoring.
Browse files Browse the repository at this point in the history
  • Loading branch information
@PiotrJustyna
PiotrJustyna committed Feb 23, 2016
1 parent 8047b46 commit cffb4b5
Show file tree
Hide file tree
Showing 6 changed files with 181 additions and 60 deletions.
28 changes: 1 addition & 27 deletions Roller/Core.hs
View file
Expand Up @@ -4,37 +4,11 @@ import Roller.Types
import Roller.Parse
import Roller.CLI

import System.Environment (getArgs)
import System.Random (randomRIO)
import Control.Applicative
import Control.Monad (join, replicateM, replicateM_)
import System.Environment (getArgs)
import Data.Word

positiveRoll :: Word8 -> IO Integer
positiveRoll x = randomRIO $ (1, fromIntegral x)

negativeRoll :: Word8 -> IO Integer
negativeRoll x = (*(-1)) <$> positiveRoll x

positiveRolls :: Word8 -> Word8 -> IO [Integer]
positiveRolls x y = replicateM (fromIntegral x) . positiveRoll $ y

negativeRolls :: Word8 -> Word8 -> IO [Integer]
negativeRolls x y = replicateM (fromIntegral x) . negativeRoll $ y

rolls :: [DiceExpression] -> IO [Integer]
rolls expressions = foldl (\x y -> (++) <$> x <*> (extractDiceExpressionValue y)) (pure []) expressions

extractDiceExpressionValue :: DiceExpression -> IO [Integer]
extractDiceExpressionValue expression =
case expression of
DieTerm x y -> positiveRolls x y
AddedDieTerm x y -> positiveRolls x y
SubtractedDieTerm x y -> negativeRolls x y
ConstantTerm x -> return [fromIntegral x]
AddedConstantTerm x -> return [fromIntegral x]
SubtractedConstantTerm x -> return [(-1) * (fromIntegral x)]

rollEm :: CLI (IO ())
rollEm verbose n args = maybe parseFail rollMany (parse input)
where
Expand Down
12 changes: 6 additions & 6 deletions Roller/Parse.hs
View file
Expand Up @@ -15,22 +15,22 @@ naturalNumber :: RE Char Word8
naturalNumber = read <$> some (psym isDigit)

dieTerm :: RE Char DiceExpression
dieTerm = DieTerm <$> naturalNumber <* sym dieSymbol <*> naturalNumber
dieTerm = constructDieTerm <$> naturalNumber <* sym dieSymbol <*> naturalNumber

addedDieTerm :: RE Char DiceExpression
addedDieTerm = AddedDieTerm <$> (sym additionSymbol *> naturalNumber) <* sym dieSymbol <*> naturalNumber
addedDieTerm = constructAddedDieTerm <$> (sym additionSymbol *> naturalNumber) <* sym dieSymbol <*> naturalNumber

subtractedDieTerm :: RE Char DiceExpression
subtractedDieTerm = SubtractedDieTerm <$> (sym subtractionSymbol *> naturalNumber) <* sym dieSymbol <*> naturalNumber
subtractedDieTerm = constructSubtractedDieTerm <$> (sym subtractionSymbol *> naturalNumber) <* sym dieSymbol <*> naturalNumber

constantTerm :: RE Char DiceExpression
constantTerm = ConstantTerm <$> naturalNumber
constantTerm = constructConstantTerm <$> naturalNumber

addedConstantTerm :: RE Char DiceExpression
addedConstantTerm = AddedConstantTerm <$> (sym additionSymbol *> naturalNumber)
addedConstantTerm = constructAddedConstantTerm <$> (sym additionSymbol *> naturalNumber)

subtractedConstantTerm :: RE Char DiceExpression
subtractedConstantTerm = SubtractedConstantTerm <$> (sym subtractionSymbol *> naturalNumber)
subtractedConstantTerm = constructSubtractedConstantTerm <$> (sym subtractionSymbol *> naturalNumber)

diceExpression :: RE Char [DiceExpression]
diceExpression = (:) <$> term <*> many signedTerm where
Expand Down
113 changes: 111 additions & 2 deletions Roller/Types.hs
View file
@@ -1,16 +1,37 @@
-- Dice notation taken from:
-- Dice notation:
-- https://en.wikipedia.org/wiki/Dice_notation

module Roller.Types where
module Roller.Types (
NumberOfDice,
NumberOfFacesOfEachDie,
DiceExpression,
maybeDiceExpressionDestructor,
constructDieTerm,
constructAddedDieTerm,
constructSubtractedDieTerm,
constructConstantTerm,
constructAddedConstantTerm,
constructSubtractedConstantTerm,
dieSymbol,
additionSymbol,
subtractionSymbol,
rolls
) where

import Control.Applicative
import Control.Monad (join, replicateM)
import Data.Word
import System.Random (randomRIO)

type NumberOfDice = Word8
type NumberOfFacesOfEachDie = Word8

dieSymbol = 'd'
additionSymbol = '+'
subtractionSymbol = '-'
diceLimit = 99
facesOfEachDieLimit = 99
constantLimit = 99

data DiceExpression =
DieTerm NumberOfDice NumberOfFacesOfEachDie
Expand All @@ -20,10 +41,98 @@ data DiceExpression =
| AddedConstantTerm Word8
| SubtractedConstantTerm Word8

diceExpressionDestructor :: (NumberOfDice -> NumberOfFacesOfEachDie -> Bool) -> (NumberOfDice -> NumberOfFacesOfEachDie -> Bool) -> (NumberOfDice -> NumberOfFacesOfEachDie -> Bool) -> (Word8 -> Bool) -> (Word8 -> Bool) -> (Word8 -> Bool) -> DiceExpression -> Bool
diceExpressionDestructor dieTerm addedDieTerm subtractedDieTerm constantTerm addedConstantTerm subtractedConstantTerm x = case x of
DieTerm numberOfDice numberOfFacesOfEachDie -> dieTerm numberOfDice numberOfFacesOfEachDie
AddedDieTerm numberOfDice numberOfFacesOfEachDie -> addedDieTerm numberOfDice numberOfFacesOfEachDie
SubtractedDieTerm numberOfDice numberOfFacesOfEachDie -> subtractedDieTerm numberOfDice numberOfFacesOfEachDie
ConstantTerm n -> constantTerm n
AddedConstantTerm n -> addedConstantTerm n
SubtractedConstantTerm n -> subtractedConstantTerm n

maybeDiceExpressionDestructor :: (NumberOfDice -> NumberOfFacesOfEachDie -> Bool) -> (NumberOfDice -> NumberOfFacesOfEachDie -> Bool) -> (NumberOfDice -> NumberOfFacesOfEachDie -> Bool) -> (Word8 -> Bool) -> (Word8 -> Bool) -> (Word8 -> Bool) -> Bool-> Maybe DiceExpression -> Bool
maybeDiceExpressionDestructor dieTerm addedDieTerm subtractedDieTerm constantTerm addedConstantTerm subtractedConstantTerm nothingResult x = case x of
Just diceExpression -> diceExpressionDestructor dieTerm addedDieTerm subtractedDieTerm constantTerm addedConstantTerm subtractedConstantTerm diceExpression
Nothing -> nothingResult

instance Show DiceExpression where
show (DieTerm x y) = show x ++ show dieSymbol ++ show y
show (AddedDieTerm x y) = show additionSymbol ++ show x ++ show dieSymbol ++ show y
show (SubtractedDieTerm x y) = show subtractionSymbol ++ show x ++ show dieSymbol ++ show y
show (ConstantTerm x) = show x
show (AddedConstantTerm x) = show additionSymbol ++ show x
show (SubtractedConstantTerm x ) = show subtractionSymbol ++ show x

constructDieTerm :: NumberOfDice -> NumberOfFacesOfEachDie -> DiceExpression
constructDieTerm x y
| validateDieTermParameters x y = DieTerm x y
| otherwise = error $ dieTermLimitsErrorMessage x y

constructAddedDieTerm :: NumberOfDice -> NumberOfFacesOfEachDie -> DiceExpression
constructAddedDieTerm x y
| validateDieTermParameters x y = AddedDieTerm x y
| otherwise = error $ dieTermLimitsErrorMessage x y

constructSubtractedDieTerm :: NumberOfDice -> NumberOfFacesOfEachDie -> DiceExpression
constructSubtractedDieTerm x y
| validateDieTermParameters x y = SubtractedDieTerm x y
| otherwise = error $ dieTermLimitsErrorMessage x y

constructConstantTerm :: Word8 -> DiceExpression
constructConstantTerm x
| validateConstantTermParameter x = ConstantTerm x
| otherwise = error $ constantTermLimitErrorMessage x

constructAddedConstantTerm :: Word8 -> DiceExpression
constructAddedConstantTerm x
| validateConstantTermParameter x = AddedConstantTerm x
| otherwise = error $ constantTermLimitErrorMessage x

constructSubtractedConstantTerm :: Word8 -> DiceExpression
constructSubtractedConstantTerm x
| validateConstantTermParameter x = SubtractedConstantTerm x
| otherwise = error $ constantTermLimitErrorMessage x

validateDieTermParameters :: NumberOfDice -> NumberOfFacesOfEachDie -> Bool
validateDieTermParameters x y = x <= diceLimit && y <= facesOfEachDieLimit

validateConstantTermParameter :: Word8 -> Bool
validateConstantTermParameter x = x <= constantLimit

dieTermLimitsErrorMessage :: NumberOfDice -> NumberOfFacesOfEachDie -> String
dieTermLimitsErrorMessage x y =
"Number of dice or number of faces of each die incorrect.\n"
++ "Details:\n"
++ "Given number of dice: " ++ show x ++ " (limit: " ++ show diceLimit ++ ").\n"
++ "Given number of faces of each die: " ++ show y ++ " (limit: " ++ show facesOfEachDieLimit ++ ")."

constantTermLimitErrorMessage :: Word8 -> String
constantTermLimitErrorMessage x =
"Constat incorrect.\n"
++ "Details:\n"
++ "Given constant: " ++ show x ++ " (limit: " ++ show constantLimit ++ ")."

positiveRoll :: Word8 -> IO Integer
positiveRoll x = randomRIO $ (1, fromIntegral x)

negativeRoll :: Word8 -> IO Integer
negativeRoll x = (*(-1)) <$> positiveRoll x

positiveRolls :: Word8 -> Word8 -> IO [Integer]
positiveRolls x y = replicateM (fromIntegral x) . positiveRoll $ y

negativeRolls :: Word8 -> Word8 -> IO [Integer]
negativeRolls x y = replicateM (fromIntegral x) . negativeRoll $ y

rolls :: [DiceExpression] -> IO [Integer]
rolls expressions = foldl (\x y -> (++) <$> x <*> (extractDiceExpressionValue y)) (pure []) expressions

extractDiceExpressionValue :: DiceExpression -> IO [Integer]
extractDiceExpressionValue expression =
case expression of
DieTerm x y -> positiveRolls x y
AddedDieTerm x y -> positiveRolls x y
SubtractedDieTerm x y -> negativeRolls x y
ConstantTerm x -> return [fromIntegral x]
AddedConstantTerm x -> return [fromIntegral x]
SubtractedConstantTerm x -> return [(-1) * (fromIntegral x)]
38 changes: 27 additions & 11 deletions Tests/ParseTests.hs
View file
@@ -1,3 +1,5 @@
module Main where

import Roller.Types
import Roller.Parse

Expand All @@ -7,19 +9,21 @@ import Text.Regex.Applicative

newtype NumericalTextGenerator = NumericalTextGenerator String deriving Show
newtype CorrectDieTermGenerator = CorrectDieTermGenerator String deriving Show
newtype IncorrectNumberOfDiceDieTermGenerator = IncorrectNumberOfDiceDieTermGenerator String deriving Show

instance Arbitrary NumericalTextGenerator where arbitrary = NumericalTextGenerator <$> generateNumberText
instance Arbitrary CorrectDieTermGenerator where arbitrary = CorrectDieTermGenerator <$> generateCorrectDieTerm
instance Arbitrary IncorrectNumberOfDiceDieTermGenerator where arbitrary = IncorrectNumberOfDiceDieTermGenerator <$> generateIncorrectNumberOfDiceDieTerm

main :: IO ()
main = do
print $ "Verify parse natural number given numerical text."
print "Verify parse natural number given numerical text."
quickCheck prop_ParseNaturalNumberGivenNumericalText

print $ "Verify parse natural number given nonnumerical text."
print "Verify parse natural number given nonnumerical text."
quickCheck prop_ParseNaturalNumberGivenNonnumericalText

print $ "Verify parse Die Term given correct die term text."
print "Verify parse Die Term given correct die term text."
quickCheck prop_ParseDieTermGivenCorrectDieTermText

generateDigit :: Gen Char
Expand All @@ -31,12 +35,18 @@ generateNumberText = listOf1 generateDigit
generateCorrectNumberOfDiceText :: Gen String
generateCorrectNumberOfDiceText = resize 2 $ listOf1 generateDigit

generateIncorrectNumberOfDiceText :: Gen String
generateIncorrectNumberOfDiceText = suchThat (listOf1 generateDigit) (\x -> length x > 2)

generateCorrectNumberOfFacesOfEachDieText :: Gen String
generateCorrectNumberOfFacesOfEachDieText = resize 2 $ listOf1 generateDigit

generateCorrectDieTerm :: Gen String
generateCorrectDieTerm = (++) <$> generateCorrectNumberOfDiceText <*> ((:) <$> pure 'd' <*> generateCorrectNumberOfFacesOfEachDieText)

generateIncorrectNumberOfDiceDieTerm :: Gen String
generateIncorrectNumberOfDiceDieTerm = (++) <$> generateIncorrectNumberOfDiceText <*> ((:) <$> pure 'd' <*> generateCorrectNumberOfFacesOfEachDieText)

prop_ParseNaturalNumberGivenNumericalText :: NumericalTextGenerator -> Bool
prop_ParseNaturalNumberGivenNumericalText (NumericalTextGenerator text) =
case (text =~ naturalNumber) of
Expand All @@ -47,16 +57,22 @@ prop_ParseNaturalNumberGivenNonnumericalText :: String -> Property
prop_ParseNaturalNumberGivenNonnumericalText text =
containsNoDigits text ==>
case (text =~ naturalNumber) of
Just x -> False
Just _ -> False
Nothing -> True
where
containsNoDigits x = (foldl (\y z -> if y == 0 && z `elem` x then y + 1 else y) 0 ['0' .. '9']) == 0

prop_ParseDieTermGivenCorrectDieTermText :: CorrectDieTermGenerator -> Property
prop_ParseDieTermGivenCorrectDieTermText :: CorrectDieTermGenerator -> Bool
prop_ParseDieTermGivenCorrectDieTermText (CorrectDieTermGenerator text) =
collect text $
collect (show (text =~ dieTerm)) $
True ==>
case (text =~ dieTerm) of
Just (DieTerm x y) -> True
Nothing -> False
maybeDiceExpressionDestructor
(\numberOfDice numberOfFacesOfEachDie -> numberOfDice >= 0 && numberOfDice <= 99 && numberOfFacesOfEachDie >= 0 && numberOfFacesOfEachDie <= 99)
ignoredDieTerm
ignoredDieTerm
ignoredConstantTerm
ignoredConstantTerm
ignoredConstantTerm
False
(text =~ dieTerm)
where
ignoredDieTerm = \_ _ -> False
ignoredConstantTerm = \_ -> False
46 changes: 34 additions & 12 deletions Tests/TypesTests.hs
View file
@@ -1,5 +1,6 @@
import Roller.Types

import Control.Applicative
import Data.Word
import Test.QuickCheck

Expand All @@ -23,20 +24,41 @@ main = do
print $ "Verify show SubtractedConstantTerm."
quickCheck prop_ShowSubtractedConstantTerm

prop_ShowDieTerm :: Word8 -> Word8 -> Bool
prop_ShowDieTerm x y = show (DieTerm x y) == show x ++ show dieSymbol ++ show y
prop_ShowDieTerm :: CorrectNumberOfDiceGenerator -> CorrectNumberOfFacesOfEachDieGenerator -> Bool
prop_ShowDieTerm (CorrectNumberOfDiceGenerator x) (CorrectNumberOfFacesOfEachDieGenerator y) =
show (constructDieTerm x y) == show x ++ show dieSymbol ++ show y

prop_ShowAddedDieTerm :: Word8 -> Word8 -> Bool
prop_ShowAddedDieTerm x y = show (AddedDieTerm x y) == show additionSymbol ++ show x ++ show dieSymbol ++ show y
prop_ShowAddedDieTerm :: CorrectNumberOfDiceGenerator -> CorrectNumberOfFacesOfEachDieGenerator -> Bool
prop_ShowAddedDieTerm (CorrectNumberOfDiceGenerator x) (CorrectNumberOfFacesOfEachDieGenerator y) =
show (constructAddedDieTerm x y) == show additionSymbol ++ show x ++ show dieSymbol ++ show y

prop_ShowSubtractedDieTerm :: Word8 -> Word8 -> Bool
prop_ShowSubtractedDieTerm x y = show (SubtractedDieTerm x y) == show subtractionSymbol ++ show x ++ show dieSymbol ++ show y
prop_ShowSubtractedDieTerm :: CorrectNumberOfDiceGenerator -> CorrectNumberOfFacesOfEachDieGenerator -> Bool
prop_ShowSubtractedDieTerm (CorrectNumberOfDiceGenerator x) (CorrectNumberOfFacesOfEachDieGenerator y) =
show (constructSubtractedDieTerm x y) == show subtractionSymbol ++ show x ++ show dieSymbol ++ show y

prop_ShowConstantTerm :: Word8 -> Bool
prop_ShowConstantTerm x = show (ConstantTerm x) == show x
prop_ShowConstantTerm :: CorrectConstatntGenerator -> Bool
prop_ShowConstantTerm (CorrectConstatntGenerator x) = show (constructConstantTerm x) == show x

prop_ShowAddedConstantTerm :: Word8 -> Bool
prop_ShowAddedConstantTerm x = show (AddedConstantTerm x) == show additionSymbol ++ show x
prop_ShowAddedConstantTerm :: CorrectConstatntGenerator -> Bool
prop_ShowAddedConstantTerm (CorrectConstatntGenerator x) = show (constructAddedConstantTerm x) == show additionSymbol ++ show x

prop_ShowSubtractedConstantTerm :: Word8 -> Bool
prop_ShowSubtractedConstantTerm x = show (SubtractedConstantTerm x) == show subtractionSymbol ++ show x
prop_ShowSubtractedConstantTerm :: CorrectConstatntGenerator -> Bool
prop_ShowSubtractedConstantTerm (CorrectConstatntGenerator x) = show (constructSubtractedConstantTerm x) == show subtractionSymbol ++ show x

newtype CorrectNumberOfDiceGenerator = CorrectNumberOfDiceGenerator NumberOfDice deriving Show
instance Arbitrary CorrectNumberOfDiceGenerator where arbitrary = CorrectNumberOfDiceGenerator <$> generateCorrectNumberOfDice

generateCorrectNumberOfDice :: Gen Word8
generateCorrectNumberOfDice = elements [0 .. 99]

newtype CorrectNumberOfFacesOfEachDieGenerator = CorrectNumberOfFacesOfEachDieGenerator NumberOfFacesOfEachDie deriving Show
instance Arbitrary CorrectNumberOfFacesOfEachDieGenerator where arbitrary = CorrectNumberOfFacesOfEachDieGenerator <$> generateCorrectNumberOfFacesOfEachDie

generateCorrectNumberOfFacesOfEachDie :: Gen Word8
generateCorrectNumberOfFacesOfEachDie = elements [0 .. 99]

newtype CorrectConstatntGenerator = CorrectConstatntGenerator Word8 deriving Show
instance Arbitrary CorrectConstatntGenerator where arbitrary = CorrectConstatntGenerator <$> generateCorrectConstant

generateCorrectConstant :: Gen Word8
generateCorrectConstant = elements [0 .. 99]
4 changes: 2 additions & 2 deletions roller.cabal
View file
Expand Up @@ -8,7 +8,7 @@ license: GPL-2
license-file: LICENSE
author: Piotr Justyna
maintainer: piotr.justyna@gmail.com
copyright: (c) 2015 Piotr Justyna
copyright: (c) 2016 Piotr Justyna
category: ACME
build-type: Simple
cabal-version: >= 1.10
Expand All @@ -22,7 +22,7 @@ library
Roller.Types,
Roller.Parse,
Roller.CLI
build-depends: base >= 4.6.0.1 && < 4.9,
build-depends: base >= 4.6.0.1,
random >= 1.0.1,
regex-applicative >= 0.3,
optparse-applicative >= 0.11.0
Expand Down

0 comments on commit cffb4b5

Please sign in to comment.