-- -*- haskell -*-

-- @@PLEAC@@_NAME
-- @@SKIP@@ Haskell

-- @@PLEAC@@_WEB
-- @@SKIP@@ http://www.haskell.org/

-- @@PLEAC@@_INTRO
-- @@SKIP@@ Please see http://haskell.org/haskellwiki/Cookbook for a more Haskell centered cookbook

-- @@PLEAC@@_1.0
str  = "\\n"                             -- two characters, \ and an n
str2 = "Jon 'Maddog' Orwant"             -- in haskell we can do string only with ", no single quote
str3 = "\n"                              -- a "newline" character
str4 = "Jon \"Maddog\" Orwant"           -- literal double quotes
str5 = "Multiline string must use a backslash at end of line\n\
\and a backslash at beginning of line\n";
str6 = "It is a common practice\n\
       \to indent lines\n\
       \(the indentation doesn't change the value of the string)\n"

-- @@PLEAC@@_1.1
groupNelem n = unfoldr f
    where f [] = Nothing
          f s = Just (splitAt n s)

-- split at five byte boundaries
fivers = groupNelem 5

-- chop string into individual characters:
-- nothing to do

s     = "This is what you have"
first = take 1 s                          -- "T"
start = take 2 $ drop 5 s                 -- "is"
rest  = drop 13 s                         -- "you have"
last' = last s                            -- 'e'

import Text.Regex
s = "This is what you have"

-- strings are immutable
s2 = a ++ "wasn't" ++ drop 2 b
     where (a, b) = splitAt 5 s
s3 = subRegex (mkRegex " is ") s " wasn't " -- "This wasn't what you have"

-- substitute "at" for "is", restricted to first five characters
s4 = a' ++ b
    where (a, b) = splitAt 5 s
          a' = subRegex (mkRegex "is") a "at"
-- do it another way
import Text.Regex
import qualified Control.Arrow as Arrow
f = uncurry (++) . Arrow.first subst . splitAt 5
    where subst s = subRegex (mkRegex "is") s "at"

-- unpack chars using parsec
import Text.ParserCombinators.Parsec
fromRight (Right v) = v
fromRight v = error ("fromRight: " ++ show v)
parseStr parser s = fromRight $ parse parser "" s
nchars n = count n anyToken

a = "To be or not to be"
b = parseStr (nchars 6 >> nchars 6) a -- "or not"

-- not same example as perl's unpack with "X5" which means "back up a byte"
-- here is an example using lookAhead where we start again at some point
[b3,c3] = parseStr (sequence [ lookAhead p1, p2 ]) a -- ["or","be"]
          where p1 = nchars 6 >> nchars 2
                p2 = nchars 3 >> nchars 2


import List
cut2fmt l = zipWith (-) l (1:l)
applyfmt fmt s = l ++ [s']
    where (s', l) = mapAccumL f s fmt
          f s n = (s',subs)
              where (subs,s') = splitAt n s

fmt = cut2fmt [8,14,20,26,30] -- [7,6,6,6,4]
l = applyfmt fmt "12345678912345678901234567890123456789" 
-- 1234567 891234 567890 123456 7890 123456789

-- @@PLEAC@@_1.2
-- boolean operators only work on booleans
a = b || c

-- if you have an optional value, use type Maybe
import Maybe
v1 = fromMaybe "b" $ Just "a"   -- "a"
v2 = fromMaybe "b" $ Nothing    -- "b"

-- to combine Maybe values, you can use mplus
import Control.Monad (mplus)

v1' = (Just "a") `mplus` (Just "b") -- Just "a"
v2' = Nothing `mplus` (Just "b")    -- Just "b"

-- you could also define some perlish things:
class Default_val a where
    default_val :: a
    is_default_val :: a -> Bool

instance Default_val [a] where 
    default_val = []
    is_default_val = null
instance Default_val Num where 
    default_val = 0
    is_default_val = (== 0)

a &&& b = if a.is_default_val then default_val else b
a ||| b = if a.is_default_val then b else a

foo = bar ||| "DEFAULT VALUE"

--
import Maybe
import System
argv0 = fmap listToMaybe getArgs
dir = fmap (fromMaybe "/tmp") argv0

-- or
dir' = fmap (head . (++ ["/tmp"])) getArgs

-- @@PLEAC@@_1.3
-- no side effect in haskell => swap is a nonsense

-- @@PLEAC@@_1.4
import Char
i = ord 'e'                     -- 101
c = chr 101                     -- 'e'

import Text.Printf
printf "Number %d is character %c\n" 101 101

ascii_character_numbers = map ord "sample" -- [115,97,109,112,108,101]
word = map chr ascii_character_numbers

ibm = map (chr . (+ 1) . ord) "HAL" -- "IBM"

-- @@PLEAC@@_1.5
s = "an apple a day"
msg1 = "unique chars are: " ++ sort (nub s)
msg2 = "sum is " ++ (show $ sum $ map ord $ s)


-- slowcat -----------------------
#!/usr/bin/runghc
{-# OPTIONS_GHC -fglasgow-exts #-}

import System
import System.IO
import System.Posix
import Text.Regex

any_input [] = getContents
any_input (f:_) = readFile f

main = do (time, args') <- fmap get_time getArgs
          s <- any_input args'
          hSetBuffering stdout NoBuffering
          mapM_ (\c -> putChar c >> usleep (5000 * time)) s
    where get_time (x:args)
              | (Just [d]) <- matchRegex (mkRegex "^-([0-9]+)") x = (read d, args)
          get_time args = (1, args)


-- @@PLEAC@@_1.6
string = "Yoda said, \"can you see this?\""
allwords = words string
revwords = unwords (reverse allwords)

revwords = (unwords . reverse . words) string

-- another version of revwords which works for spaces
revwords' = (unwords . reverse . splitRegex (mkRegex " ")) string

-- yet another version using a home made version of splitRegex' which keeps the matched string
import List
import Text.Regex

-- special unfoldr (unfoldr only returns [b] whereas we also need the rest)
-- nb: we can use Control.Arrow.first which is \f (a,b) -> (f a, b)
--     and write:  Arrow.first (a :) (unfoldr' f b')
unfoldr' :: (a -> Maybe (b, a)) -> a -> ([b], a)
unfoldr' f b  =
  case f b of
   Just (a, b') -> let (l, b'') = unfoldr' f b' in (a:l, b'')
   Nothing      -> ([], b)

splitRegex' :: Regex -> String -> [(String, String)]
splitRegex' re s = 
    case unfoldr' f s of
      (l, "") -> l
      (l, s) -> l ++ [(s, "")]
    where 
      -- small helper functions which tranform matchRegexAll output
      -- to the one wanted by unfoldr'
      f = fmap f' . matchRegexAll re
      f' (before, matched, after, _) = ((before, matched), after)

words' = concatMap (\(a,b) -> [a,b]) . splitRegex' (mkRegex "\\s+")

revwords' = (concat . reverse . words') string

{-
import Test.QuickCheck
import Char

instance Arbitrary Char where
    arbitrary     = fmap chr $ choose (32,255)
    coarbitrary n = variant (ord n)

property_words' s = (concat . words') s == s
verif = quickCheck property_words'
-}
--

word = "reviver";
is_palindrome s = s == reverse s

long_palindromes = fmap (filter (\s -> s == reverse s && length s > 5) . lines) $
                      readFile "/usr/share/dict/words"

-- @@PLEAC@@_1.7

expand_tabs "" = ""
expand_tabs s = foldr1 ((++) . adjust) $ splitRegex (mkRegex "\t") s
    where adjust a = a ++ replicate (8 - (length a) `mod` 8) ' '

-- replace spaces with tab
unexpand = concat . map (reverse . unexp . reverse) . groupNelem 8 where
    unexp s = if head s == ' ' && length s == 8 
              then '\t' : dropWhile (== ' ') s
              else s
{- 
   Here is a property that can be given to quickCheck 
   property_expand s = (expand_tabs . unexpand) s == s
-}
                        
-- @@PLEAC@@_1.8
-- can't do eval in haskell

-- subRegex only allow a fixed string
-- subRegexOnceWith below takes a (String -> String) function to compute a result
-- (and do the substitution only once)
subRegexOnceWith re new s = 
    case matchRegexAll re s of
      Nothing -> s
      Just (before, matched, after, _) -> before ++ new matched ++ after
s = subRegexOnceWith (mkRegex "[0-9]+") (show . (* 2) . read) "I am 17 years old"

-- @@PLEAC@@_1.9
import Char
s1 = map toUpper "dromedary"       -- "DROMEDARY"
s2 = map toLower s1              -- "dromedary"
s3 = toUpper (head s2) : tail s2

capitalize "" = ""
capitalize (x:xs) = toUpper x : map toLower xs

-- capitalize each word's first character, downcase the rest
s4 = map capitalize $ words "thIS is a loNG liNE"

-- randcap: filter to randomly capitalize 20% of the letters
#!/usr/bin/runghc
import System
import System.IO
import Random
import Char

any_input [] = getContents
any_input (f:_) = readFile f

rand :: Int -> Int -> IO Int
rand low high = getStdRandom (randomR (low, high))

randcap :: String -> IO String
randcap = sequence . map f where
      f c = fmap (modify_char c) $ rand(1,5)
      modify_char c n = (if n == 1 then toUpper else toLower) c

main = do s <- getArgs >>= any_input
          randcap s >>= putStr

-- @@PLEAC@@_1.10
s = "I have " ++ show (n+1) ++ " guanacos."

-- multiline strings are quite ugly in haskell
-- so skipping the send_mail example

-- @@PLEAC@@_1.11
var = "your text\n\
      \goes here\n"

-- @@PLEAC@@_1.12
import List
joinString :: String -> [String] -> String
joinString s = concat . intersperse s

input = "Folding and splicing is the work of an editor,\
        \ not a mere collection of silicon and mobile electrons!"

wrap columns first_indent indent s =
        joinString "\n" $ wgroup (tail first_indent) (words s)
        where wgroup current [] = [current]
              wgroup current (w : ws) =
                if length current + length w + 1 < columns 
                then wgroup (current ++ " " ++ w) ws 
                else current : wgroup (indent ++ w) ws


-- another version
wrap_simple columns s =
    joinString "\n" $ map unwords $ groupWhile pred $ words s
    where pred = (<= columns) . sum . map ((+1) . length)

wrap columns first_indent indent s =
    first_indent ++ joinString ("\n" ++ indent) (map unwords $ first : next)
    where (first, rest) = spanWhile (pred $ columns - length first_indent) (words s)
          next = groupWhile (pred $ columns - length indent) rest 
          pred width = (<= width) . sum . map ((+1) . length)

spanWhile :: ([a] -> Bool) -> [a] -> ([a],[a])
spanWhile p l = spanWhile' [] l              
    where spanWhile' seen [] = (seen, [])
          spanWhile' seen (x:xs) =
              let seen' = seen ++ [x] in
              if p seen' then spanWhile' seen' xs else (seen, x:xs)

groupWhile :: ([a] -> Bool) -> [a] -> [[a]]
groupWhile p l = case spanWhile p l of
                   ([], []) -> []
                   (l', []) -> [l']
                   (l', rest) -> l' : groupWhile p rest

-- @@PLEAC@@_1.13
import Text.Regex
import Char

subRegexWith re new s =
    case matchRegexAll re s of
      Nothing -> s
      Just (before, matched, after, _) -> before ++ new matched ++ (subRegexWith re new after)

quoteMeta :: String -> String
quoteMeta = concatMap (\c -> if (isAlphaNum c) then [c] else ['\\', c])

t1 = subRegex (mkRegex $ quoteMeta "^") "foo^bar" "+" -- "foo+bar" (without the quoteMeta, it goes into a dead loop)
t2 = subRegex (mkRegex $ quoteMeta "${") "${foo}bar" "{" -- "{foo}bar"
t3 = subRegexWith (mkRegex "\\$\\{[^}]*\\}") (map toUpper) "${foo}bar}" -- "${FOO}bar}"

-- @@PLEAC@@_1.14
trim_beg, trim_end, trim :: String -> String
trim_beg = snd . span isSpace
trim_end = reverse . trim_beg . reverse
trim = trim_end . trim_beg

trimmed = ">" ++ trim "\t       `Here' \t \t \n\n\n" ++ "<"

-- @@PLEAC@@_1.15
parse_csv :: String -> [String]
parse_csv s = case lex s of
        (x, "") -> [x]
        (x, xs) -> x : parse_csv xs
      where
           lex "" = ("", "")
           lex (',':xs) = ("",xs)
           lex ('"':xs) = (x++x',xs'') where (x,xs') = lexString xs
                                             (x',xs'') = lex xs'         
           lex (other:xs) = (other:x,xs') where (x,xs') = lex xs                                       

           lexString ('"':xs) = ("",xs)
           lexString ('\\':c:xs) = ('\\':c:x , xs') where (x,xs') = lexString xs
           lexString (c:xs) = (c:x,xs') where (x,xs') = lexString xs

-- the same using Parsec
import Text.ParserCombinators.Parsec

fromRight (Right v) = v
fromRight v = error ("fromRight: " ++ show v)
parseStr parser s = fromRight $ parse parser "" s
toList = fmap (\c -> [c])
many_ = fmap concat . many

parse_csv' = parseStr $ (quoted_string <|> raw_string) `sepBy` char ','
    where quoted_string = between (char '"') (char '"') (chars_until '"')
          raw_string = chars_until ','
          chars_until c = many_ (sequence [ char '\\', anyChar ] <|> toList (noneOf [c]))

test_string = "XYZZY,\"\",\"O'Reilly, Inc\",\"Wall, Larry\",\"a \\\"glub\\\" bit,\",5,\"Error, Core Dumped\""

output = concatMap format_it $ zip [0..] (parse_csv test_string)
    where format_it (line, s) = show line ++ " : " ++ s ++ "\n"

-- @@PLEAC@@_1.16
import List
import Maybe
import Char
import System.Posix.User

soundex name = (chars!!0) : concatMap show codes'
    where
      chars = map toUpper (filter isAlpha name)

      -- duplicate consecutive soundex digits are skipped
      codes = map head $ group $ map letter_to_code chars

      -- remove first, remove codes 0, add right-pad with 0
      codes' = take 3 (filter (/= 0) (tail codes) ++ [0, 0..])

letter_to_code :: Char -> Int
letter_to_code c = snd $ fromJust $ find (\(letters, _) -> c `elem` letters) letters_code
letters_code =
    [ ("AEIOUYHW", 0) , ("BFPV", 1) , ("CGJKQSXZ", 2) , ("DT", 3) , ("L", 4) , ("MN", 5) , ("R", 6) ]
          
errors = filter (\(code,name) -> code /= soundex name)
            [ ("H452", "holmes")
            , ("A355", "adomomi")
            , ("V536", "vonderlehr")
            , ("B400", "ball")
            , ("S000", "shaw")
            , ("J250", "jackson")
            , ("S545", "scanlon")
            , ("S532", "saintjohn")
            , ("K525", "kingsmith")
            , ("B331", "booth-davis")
            , ("K530", "Knuth")
            , ("K530", "Kant")
            , ("L300", "Lloyd")
            , ("L300", "Ladd")
            ]


-- one need to flush between putStr and getLine,
--   it would not be needed if we had printer a newline
-- the other solution is to disable buffering with hSetBuffering
putStr_getLine s = do putStr s
                      hFlush stdout
                      getLine

msoundex = do user <- putStr_getLine "Lookup user: "
              matching <- fmap (filter $ matches user) getAllUserEntries
              mapM_ (putStrLn . format_user) matching
    where 
      matches wanted user = soundex wanted `elem` (map soundex $ userName user : words (userGecos user))
      format_user user = userName user ++ ": " ++ userGecos user
                         
-- TODO, pstyle and psgrep                       
                         
----------------------------------------------------------------------------------------------------
-- @@PLEAC@@_2.1
-- using readIO
is_integer s = catch (do readIO s :: IO Int
                         putStrLn "is an integer")
                     (\_ -> putStrLn "is not")

-- using regexp
is_integer = isJust . matchRegex (mkRegex "^[+-]?[0-9]+$")

-- using reads
read_maybe s = case reads s of
                 [ (v, "") ] -> Just v
                 _ -> Nothing

is_integer s = isJust (read_maybe s :: Maybe Int)
is_float s = isJust (read_maybe s :: Maybe Double)

-- @@PLEAC@@_2.2

-- equal_num num1 num2 accuracy : returns true if num1 and num2 are
--   equal to accuracy number of decimal places
equal_num n1 n2 accuracy = abs (n1 - n2) < 10 ^^ (-accuracy)

wage = 536          -- $5.36/hour
week = 40 * wage    -- $214.40
weekwage :: String
weekwage = printf "One week's wage is: $%.2f\n" (week / 100 :: Double)

-- @@PLEAC@@_2.3
rounded = round unrounded

a = 0.255 :: Double
b = printf "%.2f" a
t = do putStrLn ("Unrounded: " ++ show a ++ "\nRounded: " ++ b)
       printf "Unrounded: %f\nRounded: %.2f\n" a a
-- Unrounded: 0.255
-- Rounded: 0.26
-- Unrounded: 0.255
-- Rounded: 0.26


a = [3.3, 3.5, 3.7, -3.3]
t = let l = map (\n -> printf "%.1f\t%d\t%d\t%d" (n :: Double) (truncate n :: Int)
                                                 (floor n :: Int) (ceiling n :: Int)) a in
    putStrLn (unlines $ "number\ttrncate\tfloor\tceiling" : l)

-- nb: to have a better looking output, use %4.1f and %2d instead of %.1f and %d

-- @@PLEAC@@_2.4
bin2dec :: String -> Integer
bin2dec = foldr (\c s -> s * 2 + c) 0 . reverse . map c2i
    where c2i c = if c == '0' then 0 else 1
-- bin2dec "0110110" == 54

dec2bin = map i2c . reverse . unfoldr decomp
    where decomp n = if n == 0 then Nothing else Just(n `mod` 2, n `div` 2)
          i2c i = if i == 0 then '0' else '1'
-- dec2bin 54 == "110110"

{-
import Test.QuickCheck
property_bindec n = n >= 0 ==> (bin2dec . dec2bin) n == n
verif = quickCheck property_bindec
-}

-- @@PLEAC@@_2.5

-- clean & pure way:
m1 = putStrLn $ "Infancy is: " ++ unwords (map show [0..2])
-- Infancy is: 0 1 2 

-- imperative way:
m2 = do putStr "Infancy is: "
        mapM_ (printf "%d ") [0 :: Int .. 2]
        putStrLn ""

-- imperative way':
m2' = do putStr "Infancy is: "
         mapM_ (\n -> putStr $ show n ++ " ") [0 :: Int .. 2]
         putStrLn ""

-- [0,2..8] == [0,2,4,6,8]

-- @@PLEAC@@_2.6
roman n = concat $ reverse $ snd $ mapAccumL transform n sets
    where
      transform n set = (n `div` 10, roman set (n `mod` 10))
      roman (i,v,x) n = l !! n
          where l = [ [], [i], [i,i], [i,i,i], [i,v], [v], [v,i], [v,i,i], [v,i,i,i], [i,x] ]
      sets = [('I','V','X'), ('X','L','C'), ('C','D','M'), ('M',too_big,too_big)] 
      too_big = error "roman: number greater than 3999"

arabic = sum . snd . mapAccumL set_sign 0 . map c2i . reverse
    where
      -- if the roman digit is smaller than biggest digit so far, substract it (eg: I is -1 in IV)
      set_sign max i = if i >= max then (i, i) else (max, -i)
      c2i c = case toUpper c of 
                'I' -> 1; 'V' -> 5; 'X' -> 10; 'L' -> 50 
                'C' -> 100; 'D' -> 500; 'M' -> 1000

roman_fifteen = roman 15 -- "XV"
s1 = "Roman for fifteen is " ++ roman_fifteen
arabic_fifteen = arabic roman_fifteen
s2 = "Converted back, " ++ roman_fifteen ++ " is " ++ show arabic_fifteen

{-
property_roman_arabic n = n >= 0 && n < 4000 ==> (arabic . roman) n == n
verif = quickCheck property_roman_arabic
-}

-- @@PLEAC@@_2.7
import Random
import Control.Monad (replicateM)

rand :: Int -> Int -> IO Int
rand low high = getStdRandom (randomR (low, high))

n = rand 25 75 -- [25,75]

random_elt l = do i <- rand 0 (length l - 1)
                  return (l !! i)

password = replicateM 8 (random_elt chars)
    where chars = concat [ ['A'..'Z'], ['a'..'z'], ['0'..'9'], "!@$%^&*" ]


-- random_elt can be also be written
random_elt' l = fmap (l !!) (rand 0 $ length l - 1)

-- @@PLEAC@@_2.8
srand = setStdGen . mkStdGen

randfixed = do srand 2
               rand 1 10

-- @@PLEAC@@_2.9
-- you can provide your own random generator by playing with the StdGen type

-- @@PLEAC@@_2.10
std_rand :: IO Double
std_rand = getStdRandom (randomR (0,1))

gaussian_rand = 
    do r1 <- std_rand
       r2 <- std_rand
       let u1 = 2*r1 - 1
       let u2 = 2*r2 - 1
       let w  = u1*u1 + u2*u2 -- variance
       if w >= 1 
         then gaussian_rand
         else let w2 = sqrt ((-2 * log w) / w) in 
              return (u2*w2, u1*w2) -- gaussian-distributed numbers

mean = 25
sdev = 2
t = do (r, _) <- gaussian_rand 
       let salary = r * sdev + mean
       printf "You have been hired at $%.2f\n" salary

-- @@PLEAC@@_2.11
deg2rad d = d * pi / 180
rad2deg r = r * 180 / pi

degree_sine = sin . deg2rad

-- @@PLEAC@@_2.12
asin_val = asin 1
acos_val = acos 1

-- @@PLEAC@@_2.13
v = log 10

log10 = logBase 10

t = putStrLn $ "log10(10,000)=" ++ log10 10000
-- log10(10,000) = 4

-- @@PLEAC@@_2.14
-- no standard matrix function in haskell library
-- here is a simple implementation
-- see also http://darcs.haskell.org/hugs98/demos/Matrix.hs
--       or http://darcs.haskell.org/nofib/ghc/matrix/Matrix.hs

sum_product :: Num a => [a] -> [a] -> a
sum_product u v = sum (zipWith (*) u v)

matrix_zipWith f a b = [zipWith f ak bk | (ak,bk) <- zip a b]

add_matrices a b = matrix_zipWith (+)

inner_product :: Num a => [[a]] -> [[a]] -> [[a]]
inner_product a b = mult a (transpose b)
    where mult [] _ = []
          mult (a_x:a_xs) b = [sum_product a_x bi | bi <- b] : mult a_xs b

a = [ [3, 2, 3]
    , [5, 9, 8] ]
b = [ [4, 7]
    , [9, 3]
    , [8, 1] ]
c = inner_product a b

-- @@PLEAC@@_2.15
import Complex

a = 3 :+ 5    -- 3 + 5i
b = 2 :+ (-2) -- 2 - 2i
c = a * b     -- 16 + 4i

t1 = (realPart c, imagPart c, conjugate c) --  16, 4, 16-4i

d = 3 :+ 4
t2 = sqrt d  -- 2 + i

-- @@PLEAC@@_2.16
-- "read" handles both octal and hexadecimal when prefixed with 0x or 0o
-- here are versions adding the prefix and calling "read"
hex s = read ("0x" ++ s) :: Integer
oct s = read ("0o" ++ s) :: Integer

-- hex "45" == 69
-- oct "45" == 37
-- hex "45foo" => Exception: Prelude.read: no parse

-- calling explicitly readHex or readOct:
hex = fst . head . Numeric.readHex
oct = fst . head . Numeric.readOct

-- one need to flush between putStr and getLine,
--   it would not be needed if we had printer a newline
-- the other solution is to disable buffering with hSetBuffering
putStr_getLine s = do putStr s
                      hFlush stdout
                      getLine

t = do s <- putStr_getLine "Gimme a number in decimal, octal, or hex: "
       let n = read s :: Integer
       printf "%d %x %o\n" n n n

t' = do permissions <- putStr_getLine "Enter file permission in octal: "
        putStrLn $ "The decimal value is " ++ show (oct permissions)


-- @@PLEAC@@_2.17
-- (using joinString and groupNelem from "Helpers")
commify = reverse . joinString "," . groupNelem 3 . reverse
-- commify "-1740525205" == "-1,740,525,205"

-- a version handling decimal numbers (using subRegexOnceWith from "Helpers")
commify' = subRegexOnceWith (mkRegex "[0-9]+") commify
-- commify' "-1740525205.000001" == "-1,740,525,205.000001"


-- @@PLEAC@@_2.18
hours = 2
s = "It took " ++ show hours ++ " hour" ++ if hours == 1 then "" else "s"

s2 = printf fmt (hours :: Int) :: String
    where fmt = if hours == 1 then "%d hour is enough.\n" else "%d hours are enough.\n"


-- subRegex doesn't return wether it succeeded or not
-- calling matchRegex first
subRegexMaybe :: Regex -> String -> String -> Maybe String
subRegexMaybe re s repla = do matchRegex re s -- discard the result
                              Just (subRegex re s repla)

subRegexMany :: [(String, String)] -> String -> Maybe String
subRegexMany regexps s = msum (map try_one regexps)
    where try_one (re, repla) = subRegexMaybe (mkRegex re) s repla
-- note the use of msum to take the first (Just _) in the list
-- here msum is used with type [Maybe a] -> Maybe a

noun_plural s = fromMaybe (error "can't get here") (subRegexMany regexps s)
    where regexps = [ ("ss$", "sses")
                    , ("([psc]h)$", "\\1es")
                    , ("z$", "zes")
                    , ("ff$", "ffs")
                    , ("f$", "ves")
                    , ("ey$", "eys")
                    , ("y$", "ies")
                    , ("ix$", "ices")
                    , ("([sx])$", "\\1es")
                    , ("(.)$", "\\1s") -- note that subRegex is unsafe if the regexp matches an empty strings, cf documentation
                    ]

s = unlines $ map (\s -> "One " ++ s ++ ", two " ++ noun_plural s ++ ".") $ words test_words
    where test_words = "fish fly ox \
                       \species genus phylum \
                       \cherub radius jockey \
                       \index matrix mythos \
                       \phenomenon formula"

-- @@PLEAC@@_2.19
#!/usr/bin/runghc

import List
import System
import Text.Printf

-- from http://haskell.org/haskellwiki/99_questions/31_to_41#Problem_36
encode :: Eq a => [a] -> [(a, Int)]
encode = map (\x -> (head x, length x)) . group

primeFactors n = factor n primes
  where factor n (p:ps) | p*p > n = [n]
                        | n `mod` p /= 0 = factor n ps
                        | otherwise = p : factor (n `div` p) (p:ps)
        primes = 2 : filter ((==1) . length . primeFactors) [3,5..]

main = getArgs >>= mapM_ do_one
    where do_one n = printf "%-10s %s\n" n (to_string $ encode $ primeFactors $ read n)
          to_string [(_, 1)] = "PRIME"
          to_string l = unwords $ map (\(n,power) -> show n ++ to_string_power power) l
          to_string_power p = if p == 1 then "" else "**" ++ show p

{-
% bigfact  8 9 96 2178
8          2**3
9          3**2
96         2**5 3
2178       2 3**2 11**2
% bigfact 239322000000000000000000
239322000000000000000000 2**19 3 5**18 39887
% bigfact 25000000000000000000000000
25000000000000000000000000 2**24 5**26
-}


-- @@PLEAC@@_3.0
-- you can use haskell-98 standard module:
import Time

date = fmap show getClockTime   -- "Wed Apr 25 19:43:29 CEST 2007"
localtime = getClockTime >>= toCalendarTime
-- => CalendarTime {ctYear = 2007, ctMonth = April, ctDay = 25, ctHour = 19, ctMin = 46, ctSec = 41, ctPicosec = 214805000000, ctWDay = Wednesday, ctYDay = 114, ctTZName = "CEST", ctTZ = 7200, ctIsDST = True}

utc_time = fmap toUTCTime getClockTime
-- => CalendarTime {ctYear = 2007, ctMonth = April, ctDay = 25, ctHour = 17, ctMin = 47, ctSec = 59, ctPicosec = 325921000000, ctWDay = Wednesday, ctYDay = 114, ctTZName = "UTC", ctTZ = 0, ctIsDST = False}

t = do tm <- localtime
       putStrLn $ "Today is day " ++ show (ctYDay tm) ++ " of the current year"
-- => Today is day 114 of the current year


-- or you can use new "time library":
import Data.Time

date = getCurrentTime
-- "2008-04-18 14:11:22.476894 UTC"

t = do today <- fmap utctDay getCurrentTime      
       let (year, _, _) = toGregorian today
       let days = diffDays today (fromGregorian year 0 0)
       putStrLn $ "Today is day " ++ show days ++ " of the current year"
-- => Today is day 108 of the current year

-- @@PLEAC@@_3.1
import Data.Time
import System.Locale (defaultTimeLocale)

t = do tm <- getCurrentTime
       let (year, month, day) = toGregorian (utctDay tm)
       printf "The current date is %04d %02d %02d\n" year month day

t2 = do tm <- getCurrentTime
        return $ "The current date is " ++ show (utctDay tm)
-- The current date is 2008-04-18

t3 = fmap (formatTime defaultTimeLocale "%Y-%m-%d") getCurrentTime
-- => 2008-04-18

-- @@PLEAC@@_3.2
import Data.Time
import Data.Time.Clock.POSIX

-- !! epoch is not the "base" value in Data.Time, so do not use it unless you !!
-- !! really need it !!

-- if you want epoch, use:
t = getPOSIXTime                -- 1208529250.856017s

-- if you want to get epoch from a time, use:
t2 = fmap utcTimeToPOSIXSeconds getCurrentTime -- 1208529250.856017s

-- @@PLEAC@@_3.3
import System.Time
import Data.Time
import Data.Time.Clock.POSIX

epoch = 111111
t1 = posixSecondsToUTCTime epoch      -- 1970-01-02 06:51:51 UTC
t2 = timeToTimeOfDay (utctDayTime t1) -- 06:51:51

-- @@PLEAC@@_3.4
import Data.Time

ten_seconds_before = addUTCTime (-10)
t = do now <- getCurrentTime
       return (now, ten_seconds_before now)
-- (2008-04-18 14:48:33.075113 UTC,
--  2008-04-18 14:48:23.075113 UTC)

-- ten_seconds_before can also be written:
ten_seconds_before (UTCTime day time) = UTCTime day (time - 10)
ten_seconds_before t = t { utctDayTime = utctDayTime t - 10 }


birth_date = fromGregorian 1973 1 18
t  = "Nat was 55 days old on: " ++ show (addDays 55 birth_date)
-- Nat was 55 days old on: 1973-03-14

-- @@PLEAC@@_3.5
import Data.Time
import Data.Time.Clock.POSIX

bree = UTCTime (fromGregorian 1981 6 16) (timeOfDayToTime $ TimeOfDay 4 35 25) -- 1981-06-16 04:35:25 UTC
nat  = UTCTime (fromGregorian 1973 1 18) (timeOfDayToTime $ TimeOfDay 3 45 50) -- 1973-01-18 03:45:50 UTC
-- or simpler:
bree' = read "1981-06-16 04:35:25" :: UTCTime
nat'  = read "1973-01-18 03:45:50" :: UTCTime

difference = diffUTCTime bree nat / posixDayLength
t = "There were " ++ (show $ round difference) ++ " days between Nat and Bree"
-- There were 3071 days between Nat and Bree

toFloat n = realToFrac n :: Float
t2 = printf "There were %.2f days between Nat and Bree" (toFloat difference) :: String
-- There were 3071.03 days between Nat and Bree

-- @@PLEAC@@_3.6
import Data.Time
import Data.Time.Calendar.MonthDay
import Data.Time.Calendar.OrdinalDate
import Locale

(year, month, day) = (1981, 6, 16)

t = do printf "%d/%d/%d was a %s\n" year month day week_day_name
       printf "%d/%d/%d was day %d of the week %d\n" year month day week_day week
       printf "%d/%d/%d was day %d of month %d\n" year month day month_day month_
       printf "%d/%d/%d was day %d of year %d\n" year month day year_day year_
    where date = (fromGregorian year month day)
          (week, week_day) = sundayStartWeek date
          (_, month_, month_day) = toGregorian date
          (year_, year_day) = toOrdinalDate date
          (week_day_name, _) = wDays defaultTimeLocale !! week_day
-- 1981/6/16 was a Tuesday
-- 1981/6/16 was day 2 of the week 24
-- 1981/6/16 was day 16 of month 6
-- 1981/6/16 was day 167 of year 1981

-- @@PLEAC@@_3.7
import Data.Time
import Data.Time.Format
import Data.Time.Clock.POSIX
import Locale

day :: Day
day = readTime defaultTimeLocale "%F" "1998-06-03"

-- calculate epoch seconds at midnight on that day in UTC
epoch = utcTimeToPOSIXSeconds (UTCTime day 0)
-- 896832000s

-- readTime can return a UTCTime:
epoch_ = utcTimeToPOSIXSeconds (readTime defaultTimeLocale "%F" "1998-06-03")

-- it seems readTime is not flexible, 
-- for example "%d/%m/%Y" can't handle 16/6/1981, only 16/06/1981
--
-- here is an alternative solution, using regexp
import Data.Time
import Data.Time.Clock.POSIX
import Text.Regex

day = fromGregorian (read year) (read month) (read day)
      where Just [year, month, day] = matchRegex (mkRegex "(.*)-(.*)-(.*)") "1998-06-03"
-- 1998-06-03

-- @@PLEAC@@_3.8
-- formatTime from Data.Time.Format allow powerful time formatting:
import Data.Time
import Data.Time.Format
import Locale

t = do now <- getCurrentTime
       return $ formatTime defaultTimeLocale "The date is %A (%a) %d/%m/%Y" now
-- "The date is Tuesday (Tue) 28/10/2008"

-- @@PLEAC@@_3.9
-- getCurrentTime/UTCTime has an accuracy of 1 picosecond, full precision is used by default
import Data.Time
import System.Posix.Unistd

t = do t1 <- getCurrentTime
       usleep 100000 -- 10