Permalink
Browse files

Merge branch 'master' of https://github.com/yav/HollingBerries into yav

  • Loading branch information...
2 parents 06d14d6 + 9877e94 commit 33422712c82701950af612c1d8a30c4558213560 @apauley committed May 21, 2012
Showing with 244 additions and 0 deletions.
  1. +30 −0 haskell/yav/LICENSE
  2. +13 −0 haskell/yav/README.markdown
  3. +2 −0 haskell/yav/Setup.hs
  4. +17 −0 haskell/yav/holling.cabal
  5. +182 −0 haskell/yav/holling.hs
View
30 haskell/yav/LICENSE
@@ -0,0 +1,30 @@
+Copyright (c)2012, Iavor S. Diatchki
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Iavor S. Diatchki nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
View
13 haskell/yav/README.markdown
@@ -0,0 +1,13 @@
+To build the program:
+
+ cabal install --bindir=.
+
+Note that this will download and install any missing libraries.
+For the dependencies of the program, take a look in `holling.cabal`.
+
+To run program:
+
+ holling ../../produce.csv prices.txt
+
+
+
View
2 haskell/yav/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
View
17 haskell/yav/holling.cabal
@@ -0,0 +1,17 @@
+Name: holling
+Version: 0.1
+Synopsis: An example of a small business app in Haskell
+License: BSD3
+License-file: LICENSE
+Author: Iavor S. Diatchki
+Maintainer: iavor.diatchki@gmail.com
+Build-type: Simple
+Extra-source-files: README.markdown
+Cabal-version: >=1.2
+
+
+Executable holling
+ Main-is: holling.hs
+ Build-depends: base, containers, parsec, time
+
+
View
182 haskell/yav/holling.hs
@@ -0,0 +1,182 @@
+{-# LANGUAGE RecordWildCards #-}
+import Data.Time.Calendar
+import Text.Parsec hiding (label)
+import Text.Parsec.String
+import qualified Data.Map as Map
+import Control.Applicative ( (<*) )
+import Numeric(showFFloat)
+import System.Environment(getArgs)
+import System.IO(hPutStrLn,stderr)
+import Prelude hiding (product)
+
+
+data Product = Product
+ { supplierId :: Int
+ , productCode :: Int
+ , description :: String
+ , deliveryDate :: Day
+ , costPrice :: Int -- in cents
+ , unitCount :: Int
+ } deriving Show
+
+
+--------------------------------------------------------------------------------
+-- Bussiness Rules
+
+computePrice :: Product -> Float
+computePrice product
+ | fromPremiumSupplier product = fromInteger $ ceiling $ markup (base + 10)
+ | fromSlowSupplier product = max 0 $ markup base - 2
+ | otherwise = markup base
+
+ where
+ markup x = (fromIntegral (costPrice product) / 100) * (1 + x / 100)
+
+ base | isApple product = 40
+ | isBanana product = 35
+ | isBerry product = 55
+ | otherwise = 50
+
+
+computeSellBy :: Product -> Day
+computeSellBy product
+ | isApple product = delay (2 * 7)
+ | isBanana product = delay 5
+ | isFruit product = delay (1 * 7)
+ | otherwise = deliveryDate product -- This is not specified?
+
+ where
+ delay x
+ | fromSlowSupplier product = after $ max 0 (x - 3)
+ | otherwise = after x
+
+ after x = addDays x (deliveryDate product)
+
+
+inRange :: Int -> Int -> Product -> Bool
+inRange x y i = x <= code && code <= y
+ where code = productCode i
+
+isFruit, isApple, isBanana, isBerry :: Product -> Bool
+isFruit = inRange 1000 1999
+isApple = inRange 1100 1199
+isBanana = inRange 1200 1299
+isBerry = inRange 1300 1399
+
+fromSlowSupplier :: Product -> Bool
+fromSlowSupplier product = supplierId product `elem` [ 32, 101 ]
+
+fromPremiumSupplier :: Product -> Bool
+fromPremiumSupplier product = supplierId product `elem` [ 219, 204 ]
+
+
+--------------------------------------------------------------------------------
+
+data Label = Label
+ { price :: Float
+ , sellBy :: Day
+ , label :: String
+ }
+
+computeLabels :: Product -> [String]
+computeLabels product = replicate (unitCount product)
+ $ formatLabel
+ $ Label { label = take 31 $ description product
+ , price = computePrice product
+ , sellBy = computeSellBy product
+ }
+
+formatLabel :: Label -> String
+formatLabel l = formatPrice ++ formatDate ++ formatDescr
+ where
+ pad n c txt = replicate (n - length txt) c ++ txt
+
+ formatPrice = "R" ++ pad 8 ' ' (showFFloat (Just 2) (price l) "")
+
+ formatDate = let (y,m,d) = toGregorian (sellBy l)
+ -- This is not year 10000 compatible :-)
+ in pad 4 '0' (show y) ++ "/" ++
+ pad 2 '0' (show m) ++ "/" ++
+ pad 2 '0' (show d)
+
+ formatDescr = take 31 $ label l
+
+
+main :: IO ()
+main = do args <- getArgs
+ case args of
+ [inFile, outFile] ->
+ do ps <- parseProducts inFile
+ writeFile outFile $ unlines $ concatMap computeLabels ps
+
+ _ -> hPutStrLn stderr $ unlines
+ [ "Parameters:"
+ , " FILE Input file CSV format."
+ , " FILE File where to save results."
+ ]
+
+
+--------------------------------------------------------------------------------
+-- Parsing the inputs.
+
+number :: Num a => Parser a
+number = (fromInteger . read) `fmap` many1 digit
+
+date :: Parser Day
+date = do year <- number; char '/'
+ month <- number; char '/'
+ day <- number
+ return (fromGregorian year month day)
+
+-- This allows for the columns to be re-arranged.
+inputRow :: Int -> Map.Map String String -> Parser Product
+inputRow row fieldValues =
+ do supplierId <- get number "Supplier ID"
+ productCode <- get number "Product Code"
+ description <- get (many anyChar) "Product Description"
+ deliveryDate <- get date "Delivery Date"
+ costPrice <- get number "Unit Price"
+ unitCount <- get number "Number of Units"
+ return Product { .. }
+
+ where
+ get p field =
+ case Map.lookup field fieldValues of
+ Just str ->
+ case parse p field str of
+ Right a -> return a
+ Left err -> parserFail $ unlines
+ [ unwords ["In field", field, ", row", show row]
+ , " " ++ show err
+ ]
+ Nothing -> parserFail ("Missing field: " ++ field)
+
+inputFile :: Parser [Product]
+inputFile =
+ do headings <- csvLine
+ many $ do row <- sourceLine `fmap` getPosition
+ vals <- csvLine
+ inputRow row $ Map.fromList $ zip headings vals
+
+parseProducts :: FilePath -> IO [Product]
+parseProducts file =
+ do txt <- readFile file
+ case parse (inputFile <* eof) file txt of
+ Right inputs -> return inputs
+ Left err -> fail (show err)
+
+
+
+--------------------------------------------------------------------------------
+-- Handling of data in CSV format
+
+csvWord :: Parser String
+csvWord = between (char '"') (char '"') (many strChar) <|> many (noneOf ",\n")
+ where strChar = (char '\\' >> escChar) <|> noneOf "\""
+ escChar = char '"' <|> char '\\' <|> return '\\'
+
+csvLine :: Parser [String]
+csvLine = (csvWord `sepBy` char ',') <* ((newline >> return ()) <|> eof)
+
+
+

0 comments on commit 3342271

Please sign in to comment.