-- -*- 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 Data.List

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 =
        intercalate "\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 =
    intercalate "\n" $ map unwords $ groupWhile pred $ words s
    where pred = (<= columns) . sum . map ((+1) . length)

wrap columns first_indent indent s =
    first_indent ++ intercalate ("\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
                         
-- @@PLEAC@@_1.17
-- download the following standalone program
module Main where

import qualified Text.Regex.PCRE.String as PCRE
import Data.Char (toLower)
import Data.List (intersperse)

transDict :: [(String,String)]
transDict =
    [("analysed"      ,"analyzed")
    ,("built-in"      ,"builtin")
    ,("chastized"     ,"chastised")
    ,("commandline"   ,"command-line")
    ,("de-allocate"   ,"deallocate")
    ,("dropin"        ,"drop-in")
    ,("hardcode"      ,"hard-code")
    ,("meta-data"     ,"metadata")
    ,("multicharacter","multi-character")
    ,("multiway"      ,"multi-way")
    ,("non-empty"     ,"nonempty")
    ,("non-profit"    ,"nonprofit")
    ,("non-trappable" ,"nontrappable")
    ,("pre-define"    ,"predefine")
    ,("preextend"     ,"pre-extend")
    ,("re-compiling"  ,"recompiling")
    ,("reenter"       ,"re-enter")
    ,("turnkey"       ,"turn-key")]

transWord :: String -> String
transWord word = case (lookup (map toLower word) transDict) of
                   Just trans -> trans
                   Nothing -> word

transDictRegex :: IO PCRE.Regex
transDictRegex = do
  compres <- PCRE.compile compopt execopt pattern
  case compres of
    Left (offset, string)
        -> error $
           "Regex pattern error" ++
           " at offset " ++ show offset ++
           " for string: " ++ string
    Right regex
        -> return regex
  where pattern = "(" ++ (concat $ intersperse "|" $ map fst transDict) ++ ")"
        compopt = PCRE.compCaseless + PCRE.compMultiline + PCRE.compUTF8
        execopt = PCRE.execBlank

matchRegex :: String -> IO (String, String, String)
matchRegex input = do
  regex <- transDictRegex
  execres <- PCRE.regexec regex input
  case execres of
    Left err -> error $ "regexec WrapError " ++ show err ++ "for: " ++ input
    Right Nothing -> return (input, [], [])
    Right (Just (head, word, tail, _)) -> return (head, word, tail)

translate :: String -> IO String
translate [] = do return []
translate input = do
  (head, word, tail) <- matchRegex input
  tailTrans <- (translate tail)
  return $ head ++ (transWord word) ++ tailTrans

main :: IO ()
main = do getContents >>= translate >>= putStr


-- @@PLEAC@@_1.18
-- download the following standalone program
module Main where

import Data.Char (isSpace)
import System.Time (ClockTime(..))
import System.Exit (ExitCode(..))
import System.Process (readProcessWithExitCode)
import Data.List (elemIndex, foldl', intercalate, words)
import qualified Data.Text as T

psFields :: [String]
psFields = ["flags","uid","pid","ppid","pri","nice","size","rss","wchan","stat",
            "tty","time","command"]


-- Accessors for ps output line fields -----------------------------------------

breakPSFields :: String -> [String]
breakPSFields line =
    breakFields line nInitCols
    where nInitCols        = (length psFields) - 1
          dropSpace        = dropWhile isSpace
          breakFields [] _ = []
          breakFields cs 0 = [T.unpack $ T.strip $ T.pack cs]
          breakFields cs n = let (h,t) = break isSpace $ dropSpace cs
                                 t'    = (breakFields t (n - 1))
                             in h:t'

type PSField = ([String], String)

getPSFields :: IO [PSField]
getPSFields = do
  (ecode, out, err) <- readProcessWithExitCode "ps" psargs []
  case ecode of
    ExitFailure eno -> error $ "ps failure: [" ++ show eno ++ "] " ++ err
    ExitSuccess -> return $ map (\l -> (breakPSFields l, l)) $ tail $ lines out
  where psargs = ["ax", "-o", intercalate "," psFields]

filterPSFields :: (PSField -> Bool) -> IO [PSField]
filterPSFields p = do getPSFields >>= (\fs -> return $ filter p fs)

printPSFields :: (PSField -> Bool) -> IO ()
printPSFields p = filterPSFields p >>= mapM_ (putStrLn . snd)


-- Query DSL -------------------------------------------------------------------

parseInt :: String -> Int
parseInt cs = read cs :: Int

parseClockTime :: String -> ClockTime
parseClockTime cs = TOD (toInteger secs) 0
                    where secs = foldl' (\a s -> (60 * a) + s) 0 $
                                 map (parseInt . T.unpack) $
                                 T.split (T.pack ":") (T.pack cs)

liftAcP :: String -> (String -> a) -> (a -> a -> Bool) -> a -> PSField -> Bool
liftAcP a p f v s = (p $ (fst s) !! i) `f` v
                    where i = case (a `elemIndex` psFields) of
                                Just n  -> n
                                Nothing -> error $ "Wrong ps field: " ++ a

flagsP   = liftAcP "flags"   parseInt
uidP     = liftAcP "uid"     parseInt
pidP     = liftAcP "pid"     parseInt
ppidP    = liftAcP "ppid"    parseInt
priP     = liftAcP "pri"     parseInt
niceP    = liftAcP "nice"    id
sizeP    = liftAcP "size"    parseInt
rssP     = liftAcP "rss"     parseInt
wchanP   = liftAcP "wchan"   id
statP    = liftAcP "stat"    id
ttyP     = liftAcP "tty"     id
timeP    = liftAcP "time"    parseClockTime
commandP = liftAcP "command" id

liftOpP o x y s = (x s) `o` (y s)

(&&?)    = liftOpP (&&)
infixr 3 &&?

(||?)    = liftOpP (||)
infixr 2 ||?


-- Example Runs ----------------------------------------------------------------

-- You will need below ghc command line wrapper before using this script from
-- the command line.

--   $ cat PSGrep.sh
--   #!/bin/sh
--   ghc -e "printPSFields \$ $@" PSGrep.hs

-- Rest is trivial...

--   $ ./PSGrep.sh 'flagsP (==) 0 &&? sizeP (<) 1024'
--   0     0  3019     1  19   0   256   504 -      Ss+  tty2     00:00:00 /sbin/getty 38400 tty2
--   0     0  3020     1  19   0   256   508 -      Ss+  tty3     00:00:00 /sbin/getty 38400 tty3
--   0     0  3022     1  19   0   256   500 -      Ss+  tty4     00:00:00 /sbin/getty 38400 tty4
--   0     0  3023     1  19   0   256   504 -      Ss+  tty5     00:00:00 /sbin/getty 38400 tty5
--   0     0  3024     1  19   0   256   504 -      Ss+  tty6     00:00:00 /sbin/getty 38400 tty6

                         
----------------------------------------------------------------------------------------------------
-- @@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
import Data.List
-- (using groupNelem from "Helpers")
commify = reverse . intercalate "," . 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 a precision of 1 picosecond, full precision is used by default
import Data.Time
import System.Posix.Unistd

t = do t1 <- getCurrentTime
       usleep 100000 -- 100ms
       t2 <- getCurrentTime
       return (diffUTCTime t2 t1)
-- 0.111262s

-- @@PLEAC@@_3.10
-- short sleeps:
t = do usleep 3100000

-- for even more precision, nanosleep is available

-- @@PLEAC@@_3.11
-- download the following standalone program
module Main where

import Data.Char (toLower)
import Data.Fixed (divMod')
import Data.List (intersperse, isInfixOf, foldl')
import System.Environment (getArgs)

import qualified Codec.MIME.Parse       as MIME
import qualified Data.Time.Clock        as CLOCK
import qualified Data.Time.Format       as TIME
import qualified System.Locale          as LOCALE
import qualified Text.Regex.PCRE.String as PCRE

data ServerHeader = ServerHeader {
      receivedFrom :: String
    , receivedBy   :: String
    , receivedAt   :: CLOCK.UTCTime
    } deriving (Show)

serverHeaderRegex :: IO PCRE.Regex
serverHeaderRegex = do
  let pattern = "from (.*) by (.*) with (.*); (.*)"
  compres <- PCRE.compile PCRE.compBlank PCRE.execBlank pattern
  case compres of
    Left (offset, string)
        -> error $
           "Regex pattern error" ++
           " at offset " ++ show offset ++
           " for string: " ++ string
    Right regex
        -> return regex

parseTime :: String -> CLOCK.UTCTime
parseTime time = case parseres of
                   Just utctime -> utctime
                   Nothing -> error $ "Invalid data format: " ++ time
                 where parseres = TIME.parseTime
                                  LOCALE.defaultTimeLocale
                                  "%a, %e %b %Y %X %z (%Z)"
                                  time
                                  :: Maybe CLOCK.UTCTime

parseServerHeader :: String -> IO ServerHeader
parseServerHeader input = do
  let header = concat $ intersperse " " $ words input
      headerWithFrom  = if "from" `isInfixOf` header
                        then header
                        else "from - " ++ header
  regex <- serverHeaderRegex
  execres <- PCRE.regexec regex headerWithFrom
  case execres of
    Left err -> error $ "regexec WrapError " ++ show err ++ "for: " ++ input
    Right Nothing -> error $ "Invalid server header: " ++ headerWithFrom
    Right (Just (_, _, _, [from, by, _, time]))
        -> return $ ServerHeader from by (parseTime time)

parseServerHeaders :: String -> IO [ServerHeader]
parseServerHeaders contents = do
  mapM (parseServerHeader . snd) $ reverse $ filter match headers
  where match   = (== "received") . (map toLower) . fst
        headers = fst $ MIME.parseHeaders contents

prettifyTimeDiff :: (Real a) => a -> String
prettifyTimeDiff diff =
  concat $ intersperse " " $ map (\(n,t) -> show n ++ t)
         $ if null diffs then [(0,"s")] else diffs
  where merge (tot,acc) (sec,typ) = let (sec',tot') = divMod' tot sec
                                    in (tot',(sec',typ):acc)
        metrics = [(86400,"d"),(3600,"h"),(60,"m"),(1,"s")]
        diffs = filter ((/= 0) . fst) $ reverse $ snd $ foldl' merge (diff,[]) metrics

printServerHeaders :: String -> IO ()
printServerHeaders contents = do
  headers <- parseServerHeaders contents
  mapM_ printHeader (zip headers $ (head headers) : headers)
  where printHeader (c,p) = do
          putStrLn $ "after " ++ (prettifyTimeDiff $ CLOCK.diffUTCTime (receivedAt c) (receivedAt p))
          putStrLn $ " from " ++ (receivedFrom c)
          putStrLn $ "   by " ++ (receivedBy c)
          putStrLn $ "   at " ++ (show $ receivedAt c)

main :: IO ()
main = do
  args <- getArgs
  case args of
    []         -> getContents >>= printServerHeaders
    [pathname] -> readFile pathname >>= printServerHeaders
    _          -> error "Arguments: [<PATHNAME>]"



-- @@PLEAC@@_4.0
single_level = [ "this", "that", "the", "other" ]

-- there is no non-homogeneous list. You can do things with tuples:
nested = ("this", "that", ["the", "other"]) -- (String, String, [String])

-- arrays are generally eschewed in Haskell, lists are prefered.
-- arrays are useful if you desperately need:
-- * huge amounts of raw data.
-- * constant (O(1)) lookup => use Data.Array
-- * constant (O(1)) update => use Data.Array.IO, Data.Array.ST or Data.Array.Storable
--                             (or even Data.Array.Diff)
-- see http://haskell.org/haskellwiki/Cookbook#Arrays
-- and http://www.haskell.org/haskellwiki/Modern_array_libraries for more

-- creating an Array from a list:
import Data.Array
listToArray :: [a] -> Array Int a
listToArray l = listArray (0, length l - 1) l

a1 = listToArray l1
-- => array (0,3) [(0,"Crosby"),(1,"Stills"),(2,"Nash"),(3,"Young")]

-- getting back the list
l1' = elems a1


-- creating an IOArray from a list:
import Data.Array.IO
listToIOArray :: [a] -> IO (IOArray Int a)
listToIOArray l = newListArray (0, length l - 1) l

a1 = listToIOArray l1

l1' = a1 >>= getElems 


-- @@PLEAC@@_4.1
a  = [ "quick", "brown", "fox" ]
a' = words "Why are you teasing me?"

l = lines 
      "The boy stood on the burning deck\n\
      \It was as hot as glass."

big_array = do s <- readFile "mydatafile"
               return (lines s)
-- more compact:
big_array = fmap lines (readFile "mydatafile")


-- using readProcess from "Helpers"
his_host = "www.haskell.org"
host_info = do Right info <- readProcess "nslookup" [his_host] ""
               return info

-- calling ps on our running process
import System
import System.Posix (getProcessID)

t = do id <- getProcessID
       system ("ps " ++ show id)

-- @@PLEAC@@_4.2
import Data.List
commify_series :: [String] -> String
commify_series []  = ""
commify_series [x]  = x
commify_series xs  = intercalate ", " (init xs) ++ " and " ++ (last xs)

array = ["red", "yellow", "green"]
s1 = "I have " ++ commify_series array ++ " marbles" -- I have red, yellow and green marbles
s2 = "I have " ++ concat  array ++ " marbles" -- I have redyellowgreen marbles
s3 = "I have " ++ unwords array ++ " marbles" -- I have red yellow green marbles

-- @@PLEAC@@_4.3
-- arrays can't be resized
-- similar behaviour for lists explained below

what_about_that_list x = unlines
    [ "The list now has " ++ show (length x) ++ " elements."
    , "The index of the last element is " ++ show (length x - 1) ++ "."
    , "Element .3 is`" ++ x!!3 ++ "'."
    ]

l1 = [ "Crosby", "Stills", "Nash", "Young" ]

-- remove last element
l2 = init l1    -- ["Crosby", "Stills", "Nash"]

-- keep 3 elements
l3 = take 3 l1  -- ["Crosby", "Stills", "Nash"]

-- calling what_about_that_list on l2 or l3 would raise
--   *** Exception: Prelude.(!!): index too large
-- when accessing element .3

-- grow list
l4 = take 10001 (l1 ++ repeat "")
-- same, but much less haskell'ish, prefer above
l4' = l1 ++ replicate (10001 - length l1) ""

-- writing a function that grow and shrink a list is easy:
resize_list n default_val l = take n (l ++ repeat default_val)



-- @@PLEAC@@_4.4
bad_users = filter is_valid_user all_users

t = mapM_ complain bad_users

t' = mapM_ do_it all_users
    where do_it user = do usage <- get_usage user
                          when (usage > max_quota) (complain user)

-- equivalent of "env | sort"
import System.Environment
import List
t = getEnvironment >>= putStr . format
    where format = unlines . map (\(var, val) -> var ++ "=" ++ val) . sort

-- display lines from "who" matching "simonpj" (readProcess is in "Helpers")
t = do Right s <- readProcess "who" [] ""
       mapM_ putStrLn (filter ("simonpj" `isPrefixOf`) $ lines s)

-- print file with words reversed:
t = readFile "/etc/fstab" >>= putStr . reverse_words_of_each_line
    where reverse_words_of_each_line = unlines . map (unwords . reverse . words) . lines

-- modify every element
l = map (-1 +) [1,2,3]          -- [0,1,2]

-- multiply everything in a and b by seven
l = [ ("a", [ 0.5, 3 ]), ("b", [ 0, 1 ]) ]
l' = map (\(name, xs) -> (name, map (* 7) xs)) l
-- => [ ("a", [ 3.5, 21 ]), ("b", [ 0, 7 ]) ]
-- same using Arrow.second
l_' = map (Arrow.second $ map (* 7)) l
-- for a more cryptic version, replace Arrow.second with fmap

-- same using Data.Map
import qualified Data.Map as Map
m = Map.fromList [ ("a", [ 0.5, 3 ]), ("b", [ 0, 1 ]) ]
m' = Map.map (map (* 7)) m 


-- @@PLEAC@@_4.5
-- not relevant in haskell since we have always kind of references


-- @@PLEAC@@_4.6
l = nub [ 1, 1, 2, 2, 3, 3, 3, 5 ]  -- [ 1, 2, 3, 5 ]

-- generate a list of users logged in, removing duplicates (readProcess is in "Helpers")
t = do Right s <- readProcess "who" [] ""
       let users = sort $ nub $ map (head . words) $ lines s
       putStrLn ("users logged in: " ++ unwords users)


-- @@PLEAC@@_4.7
l = [ 1, 2, 4 ] \\ [ 4, 1 ]         -- [ 2 ]

-- beware of duplicates:
xs = [ 1, 1, 2, 3, 3, 4, 5 ]
ys = [ 1, 2, 4 ]
l1 = xs \\ ys                   -- [ 1, 3, 3, 5 ]
l2 = nub xs \\ ys               -- [ 3, 5 ]
l3 = filter (`notElem` ys) xs   -- [ 3, 3, 5 ]

-- for faster operations, use Data.Set:
import qualified Data.Set as Set
l = filter (`Set.notMember` Set.fromList [ 4, 1 ]) [ 1, 2, 4 ]
-- => [ 2 ]

s1 = Set.fromList [ 1, 2, 4 ]
s2 = Set.fromList [ 4, 1 ]
s3 = Set.\\ s1 s2


-- @@PLEAC@@_4.8
a = [1, 3, 5, 6, 7, 8]
b = [2, 3, 5, 7, 9]

l1 = a `intersect` b            -- [ 3, 5, 7 ]
l2 = a `union` b                -- [ 1, 3, 5, 6, 7, 8, 2, 9 ]
l3 = a \\ b                     -- [ 1, 6, 8 ]

-- see also union and intersection in Data.Set


-- @@PLEAC@@_4.9
l = [ "Time", "Flies" ]
l2 = l ++ [ "An", "Arrow" ]   -- ["Time", "Flies", "An", "Arrow"]

insertAt n e l = before ++ [e] ++ after
    where (before, after) = splitAt n l

l3 = insertAt 2 "Like" l2 -- ["Time", "Flies", "Like", "An", "Arrow"]

replaceAt n e l = before ++ [e] ++ tail after
    where (before, after) = splitAt n l

replaceAllAt assoc l = foldr (\(n, e) -> replaceAt n e) l assoc

l4 = replaceAt 0 "Fruit" l3
l5 = replaceAllAt [ (3,"A"), (4,"Banana") ] l4
-- => ["Fruit", "Flies", "Like", "A", "Banana"]

-- arrays are better suited for modifying an element,
-- but arrays are not suited for adding elements
-- (using listToArray from "Helpers")
l3' = listToArray l3
l4' = l3' Array.// [ (0, "Fruit") ]
l5' = l4' Array.// [ (3,"A"), (4,"Banana") ]


-- @@PLEAC@@_4.10
l = reverse [1..5]       -- [5,4,3,2,1]

reverse_sort   = reverse . sort
reverse_sort'  = sortBy (\a b -> b <=> a)
reverse_sort'' = sortBy (flip (<=>))

l = reverse_sort [3,2,5,1]      -- [5,3,2,1]


-- @@PLEAC@@_4.11
-- remove n elements from front of array
(front,array') = splitAt array n

-- remove n elements from the end of array
(array',end)  = splitAt array (array.length array - n)

(this : that : friends') = [ "Peter", "Paul", "Mary", "Jim", "Tim" ]
-- this contains "Peter", that has "Paul", and friends' has "Mary", "Jim", and "Tim"

beverages = words "Dew Jolt Cola Sprite Fresca"
(beverages', pair) = splitAt (length beverages - 2) beverages 
-- pair contains ["Sprite", "Fresca"]
-- and beverages' has ["Dew", "Jolt", "Cola"]


-- @@PLEAC@@_4.12
data Employee = Employee { name, position :: String
                         , salary :: Int } deriving (Show,Eq)

employees = [ Employee { name="Jim",  position="Manager",  salary=26000 }
            , Employee { name="Jill", position="Engineer", salary=24000 }
            , Employee { name="Jack", position="Engineer", salary=22000 } ]

(Just engineer) = find ((== "Engineer") . position) employees

s = name engineer ++ " is engineer"


-- @@PLEAC@@_4.13
bigs = filter (> 1000000) nums

-- display lines from "who" matching "simonpj" (readProcess is in "Helpers")
t = do Right s <- readProcess "who" [] ""
       mapM_ putStrLn (filter ("simonpj" `isPrefixOf`) $ lines s)

-- using employees defined in previous section
engineers  = [ x | x <- employees, position x == "Engineer"]
engineers' = filter ((== "Engineer") . position) employees
-- => [ Employee { name="Jill", ... }, Employee { name="Jack", ... } ]

secondary_assistance = filter ((\x -> x >= 26000 && x < 30000) . salary) employees
-- => [ Employee { name="Jim", position="Manager", salary=26000 } ]


-- @@PLEAC@@_4.14
-- sort works for numbers
l1 = sort [100, 3, 20]          -- [3, 20, 100]
-- strings representing numbers will be sorted alphabetically
l2 = sort ["100", "3", "20"]    -- ["100", "20", "3"]

-- you may specify another sort method (not lexicographic ordering):
-- for comparing: import Data.Ord (comparing)
l3 = sortBy (comparing (read :: String -> Int)) ["100", "3", "20"] -- ["3", "20", "100"]
-- same, but may typically run faster
sortByKey f = map snd . sortBy (comparing fst) . map (\x -> (f x, x))
l3' = sortByKey (read :: String -> Int) ["100", "3", "20"]

-- more cryptic: replace (\x -> (f x, x)) with (f Arrow.&&& id)


-- @@PLEAC@@_4.15
data Employee = Employee { name, position :: String
                         , salary :: Int } deriving (Show,Eq)

employees = [ Employee { name="Jim",  position="Manager",  salary=26000 }
            , Employee { name="Jill", position="Engineer", salary=24000 }
            , Employee { name="Jack", position="Engineer", salary=22000 } ]

employee_sorted = sortBy (comparing name) employees
-- => [ Employee { name="Jack", ... }, Employee { name="Jill", ... }, Employee { name="Jim", ... } ]

sortByKey f = map snd . sortBy (comparing fst) . map (\x -> (f x, x))
sortByKeyRev f = map snd . sortBy (flip $ comparing fst) . map (\x -> (f x, x))

employee_sorted' = sortByKey name employees

ordered     = sortByKey    abs [ 1, -3, 2, 6 ] -- [ 1, 2, -3, 6 ]
ordered_rev = sortByKeyRev abs [ 1, -3, 2, 6 ] -- [ 6, -3, 2, 1 ]

names = [ "Azzz", "Za", "Bbbbbbb" ]
sort_by_2nd_char  = sortByKey (!! 1) names -- ["Za","Bbbbbbb","Azzz"]
sort_by_last_char = sortByKey last names   -- ["Za","Bbbbbbb","Azzz"]
sort_by_length    = sortByKey length names -- ["Za","Azzz","Bbbbbbb"]

--
import Text.Regex
m = readFile "/etc/passwd" >>= (putStr . unlines . sortByKey key . lines)
    where key line = case splitRegex (mkRegex ":") line of
                       (name : _ : uid : gid : _) ->
                           (read gid :: Int, read uid :: Int, name) 


-- @@PLEAC@@_4.16
import System.Posix (sleep)

-- circular lists are easily defined using infinite list
circular = [1,2,3,4,5] ++ circular

m = mapM_ do_it (take 10 circular)
    where do_it n = do putStrLn ("Handling process " ++ show n)
                       sleep 1


-- @@PLEAC@@_4.17
rand :: Int -> Int -> IO Int
rand low high = getStdRandom (randomR (low, high))

randomPermute :: [a] -> IO [a]
randomPermute []  = return []
randomPermute xs  = 
    do n <- rand 0 (length xs - 1)
       let (a, e : b) = splitAt n xs -- taking n-th element and putting it first
       ab <- randomPermute (a ++ b)
       return $ e : ab

l = randomPermute [1..5]        -- example of result: [2,3,5,1,4]


-- @@PLEAC@@_4.18
-- using groupNelem from "Helpers"
make_columns :: Int -> [String] -> [String]
make_columns screen_width mylist = 
    map concat $ transpose $ groupNelem rows $ map pad_it mylist
        where maxlen = maximum(map length mylist) + 1 -- 1 needed to make extra space
              cols = max 1 (screen_width `div` maxlen)
              rows = 1 + (length mylist `div` cols)
              pad_it s = take maxlen (s ++ repeat ' ')

-- using external program "resize -u" to get terminal size (readProcess is in "Helpers")
getTerminalSize :: IO (Maybe (Int, Int))
getTerminalSize =
    do Right s <- readProcess "resize" ["-u"] ""
       let vars = parse_shell_vars s
       return $ do x <- lookup "COLUMNS" vars
                   y <- lookup "LINES" vars
                   return (read x, read y)
    where parse_shell_vars = catMaybes . map break_it . lines
          break_it s = case break (== '=') s of
                         (_, "") -> Nothing
                         (var, _:val) -> Just (var, if last val == ';' then init val else val)

main = do size <- getTerminalSize
          let width = maybe 80 fst size
          interact (unlines . make_columns width . words)


-- @@PLEAC@@_4.19
permutations []     =  [[]]
permutations (x:xs) = [zs | ys <- permutations xs, zs <- interleave x ys ]
  where interleave x []     =  [[x]]
        interleave x (y:ys) =  [x:y:ys] ++ map (y:) (interleave x ys)
-- the list comprehension can be replaced by: concatMap (interleave x) $ permutations xs

t = mapM_ (putStrLn . unwords) $ permutations $ words "man bites dog" 
-- man bites dog
-- bites man dog
-- bites dog man
-- man dog bites
-- dog man bites
-- dog bites man


-- @@PLEAC@@_5.0
-- using simple association list
age = [ ("Nat", 24)
      , ("Jules", 25)
      , ("Josh", 17) ]

-- access by key:
Just jules_age = lookup "Jules" age    -- 25

-- using Data.Map
import qualified Data.Map as Map
age = Map.fromList [ ("Nat", 24)
                   , ("Jules", 25)
                   , ("Josh", 17) ]

-- access by key:
jules_age' = age' Map.! "Jules"   -- 25

-- same, incrementally
age1 = Map.empty
age2 = Map.insert "Nat"   24 age1
age3 = Map.insert "Jules" 25 age2
age4 = Map.insert "Josh"  17 age3
-- => Map.fromList [("Josh",17),("Jules",25),("Nat",24)]

food_color = [ ("Apple" , "red")
             , ("Banana", "yellow")
             , ("Lemon" , "yellow")
             , ("Carrot", "orange") ]

food_color' = Map.fromList food_color


-- @@PLEAC@@_5.1
food_color2 = ("Raspberry", "pink") : food_color

t = putStrLn $ "Know foods: " ++ unwords (map fst food_color2)
-- => Know foods: Raspberry Apple Banana Lemon Carrot

-- nb: it doesn't remove duplicates
food_color3 = ("Raspberry", "red") : food_color2
-- => [ ("Raspberry","red"), ("Raspberry","pink"), ("Apple","red"), ... ]
-- (see section "Finding Common or Different Keys in Two Hashes" for a solution removing duplicates)


-- same using Data.Map
food_color2' = Map.insert "Raspberry" "pink" food_color'

t' = putStrLn $ "Know foods: " ++ unwords (Map.keys food_color2')
-- => Know foods: Apple Banana Carrot Lemon Raspberry

-- nb: it does remove duplicates
food_color3' = Map.insert "Raspberry" "red" food_color2'
-- Map.fromList [("Apple","red"),("Banana","yellow"),("Carrot","orange"),("Lemon","yellow"),("Raspberry","red")]


-- @@PLEAC@@_5.2
s = map describe ["Banana", "Martini"]
    where describe name = name ++ " is a " ++ kind name ++ "."
          kind name = if isJust (lookup name food_color) then "food" else "drink"
-- => ["Banana is a food.","Martini is a drink."]

--   isJust (lookup name food_color)   
-- can be replaced by
--   name `elem` map fst food_color

-- for Data.Map, replace (isJust . lookup) with Map.member:
s' = map describe ["Banana", "Martini"]
    where describe name = name ++ " is a " ++ kind name ++ "."
          kind name = if Map.member name food_color' then "food" else "drink"
-- => ["Banana is a food.","Martini is a drink."]


-- @@PLEAC@@_5.3
-- removing key on association list is done with a simple filter:
food_color2 = filter ((/= "Banana") . fst) food_color

print_foods foods = do putStrLn $ "Keys: " ++ (unwords $ map fst foods)
                       putStrLn $ "Values: " ++ (unwords $ map snd foods)

before = print_foods food_color
-- Keys: Apple Banana Lemon Carrot
-- Values: red yellow yellow orange
after = print_foods food_color2
-- Keys: Apple Lemon Carrot
-- Values: red yellow orange


-- using Data.Map
food_color2' = Map.delete "Banana" food_color'

print_foods' foods = do putStrLn $ "Keys: " ++ (unwords $ Map.keys foods)
                        putStrLn $ "Values: " ++ (unwords $ Map.elems foods)

before' = print_foods' food_color'
-- Keys: Apple Banana Carrot Lemon
-- Values: red yellow orange yellow
after' = print_foods' food_color2'
-- Keys: Apple Carrot Lemon
-- Values: red orange yellow

-- to remove a list of keys, simply use foldr:
food_color3' = foldr Map.delete food_color' [ "Banana", "Apple", "Cabbage" ]


-- @@PLEAC@@_5.4
t  = map (\(food, color) -> food ++ " is " ++ color) food_color
-- ["Apple is red","Banana is yellow","Lemon is yellow","Carrot is orange"]
t2 = map (\(food, color) -> food ++ " is " ++ color) $ sort food_color
-- ["Apple is red","Banana is yellow","Carrot is orange","Lemon is yellow"]

-- using Data.Map
t'  = map (\(food, color) -> food ++ " is " ++ color) $ Map.assocs food_color'
-- ["Apple is red","Banana is yellow","Carrot is orange","Lemon is yellow"]

t2' = map format_it $ sort $ Map.assocs food_color'
    where format_it (food, color) = food ++ " is " ++ color
-- ["Apple is red","Banana is yellow","Carrot is orange","Lemon is yellow"]

-- you can of course get keys first, and use Map.!
t2' = map format_it $ sort $ Map.keys food_color'
    where format_it food = food ++ " is " ++ food_color' Map.! food

-- countfrom - count number of messages from each sender
#!/usr/bin/runghc

import System
import Maybe
import List

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

get_senders = catMaybes . map get_sender
    where get_sender line = if prefix `isPrefixOf` line 
                            then Just (drop (length prefix) line) 
                            else Nothing
          prefix = "From: "

main = do s <- getArgs >>= any_input
          let senders = group $ sort $ get_senders (lines s)
          mapM_ (putStrLn . format_it) $ senders
    where format_it froms@(name:_) = name ++ ": " ++ show (length froms)


-- @@PLEAC@@_5.5
-- show gives a string representation
s = show food_color
t = putStrLn s
-- => [("Apple","red"),("Banana","yellow"),("Lemon","yellow"),("Carrot","orange")]

s2  = map (\(food, color) -> food ++ " => " ++ color) food_color
-- see "Traversing a Hash" for more


-- @@PLEAC@@_5.6
-- association list as explained in previous sections keeps order


-- @@PLEAC@@_5.7
-- one can use simple list functions
lookupAll k = map snd . filter ((== k) . fst)

color_to_foods color = map fst $ filter ((== color) . snd) food_color
yellow_food = color_to_foods "yellow" -- ["Banana","Lemon"]

-- one can precompute it:
food_of_color = map (\color -> (color, color_to_foods color)) colors
                where colors = nub (map snd food_color)
-- => [("red",["Apple"]), ("yellow",["Banana","Lemon"]), ("orange",["Carrot"])]
-- then use it
yellow_food_ = fromMaybe [] (lookup "yellow" food_of_color)

-- another way to pre-compute
assocListGroupByKey :: Ord a => [(a,b)] -> [(a,[b])]
assocListGroupByKey = map factorize . groupBy same_key . sortBy (comparing fst)
    where factorize l@((user, _) : _) = (user, map snd l)          
          same_key (a,_) (b,_) = a == b
-- you can write: factorize = fst . head Arrow.&&& map snd
food_of_color = assocListGroupByKey food_color

-- or one can use a full fledged data structure
-- (need: import qualified Data.Set as Set)
food_of_color' = foldl (\l (v, k) -> Map.alter (add_it v) k l) Map.empty food_color
    where add_it val prev = Just (Set.insert val $ fromMaybe Set.empty prev)
yellow_food' = food_of_color' Map.! "yellow"
-- => Set.fromList ["Banana","Lemon"]

-- for every logged-in user, display the ttys on which it is logged
t = do Right s <- readProcess "who" [] ""
       let l = assocListGroupByKey $ map (parse_it . words) (lines s)
       mapM_ (putStrLn . format_it) l
    where format_it l (user, ttys) = user ++ ": " ++ unwords ttys
          parse_it (user : tty : _) = (user, tty)


-- @@PLEAC@@_5.8
surname = [ ("Mickey", "Mantle"), ("Babe", "Ruth") ];
first_name = map swap surname
swap (a,b) = (b,a)

Just name = lookup "Mantle" first_name -- "Mickey"

-- see also section "Hashes with Multiple Values Per Key"


-- @@PLEAC@@_5.9
t = map (\(food, color) -> food ++ " is " ++ color) $ sort food_color
-- ["Apple is red","Banana is yellow","Carrot is orange","Lemon is yellow"]

-- sorting on length of color (sortByKey is in "Helpers")
t2 = map (\(food, color) -> food ++ " is " ++ color) $ sortByKey (length . snd) food_color
-- => ["Apple is red","Banana is yellow","Lemon is yellow","Carrot is orange"]

-- using Data.Map, the simplest is to use Map.assocs and do as above
t' = map format_it $ sort $ Map.assocs food_color'
    where format_it (food, color) = food ++ " is " ++ color
-- ["Apple is red","Banana is yellow","Carrot is orange","Lemon is yellow"]

-- you can of course get keys first, and use Map.!
t_' = map format_it $ sort $ Map.keys food_color'
    where format_it food = food ++ " is " ++ food_color' Map.! food


-- @@PLEAC@@_5.10
-- food_color as per the introduction
drink_color = [ ("Galliano", "yellow"), ("Mai Tai", "blue") ]
ingested_color = drink_color ++ food_color
-- => [("Galliano","yellow"),("Mai Tai","blue"),("Apple","red"),("Banana","yellow"),("Lemon","yellow"),("Carrot","orange")]
-- (it doesn't remove duplicates, see section "Finding Common or Different Keys in Two Hashes" for a solution removing duplicates)

-- using Data.Map
drink_color' = Map.fromList drink_color
ingested_color' = Map.union drink_color' food_color'
-- => Map.fromList [("Apple","red"),("Banana","yellow"),("Carrot","orange"),("Galliano","yellow"),("Lemon","yellow"),("Mai Tai","blue")]


-- @@PLEAC@@_5.11
-- food_color as per the introduction
citrus_color = [ ("Lemon", "yellow"), ("Orange", "orange"), ("Lime", "green") ]
common = food_color ++ citrus_color
-- => [("Apple","red"),("Banana","yellow"),("Lemon","yellow"),("Carrot","orange"),("Lemon","yellow"),("Orange","orange"),("Lime","green")]
-- the duplicates are still here, to remove them:
nubByKey f = nubBy (\a b -> f a == f b)
common_ = nubByKey fst common
-- => [("Apple","red"),("Banana","yellow"),("Lemon","yellow"),("Carrot","orange"),("Orange","orange"),("Lime","green")]
-- no more duplicates

non_citrus = food_color \\ citrus_color
-- => [("Apple","red"),("Banana","yellow"),("Carrot","orange")]

-- using Data.Map
citrus_color' = Map.fromList citrus_color
common' = Map.union food_color' citrus_color'
-- => Map.fromList [("Apple","red"),("Banana","yellow"),("Carrot","orange"),("Lemon","yellow"),("Lime","green"),("Orange","orange")]
non_citrus' = Map.difference food_color' citrus_color'
-- => Map.fromList [("Apple","red"),("Banana","yellow"),("Carrot","orange")]


-- @@PLEAC@@_5.12
-- no problem here, haskell handles any kind of object for key-ing

name = mapM open_files [ "/etc/termcap", "/etc/passwd", "/bin/cat" ]
       where open_files file = do fh <- openFile file ReadMode
                                  return (fh, file)
t = do files <- fmap (map snd) name
       putStrLn $ "open files: " ++ intercalate ", " files
t2 = name >>= mapM_ display_size
    where display_size (fh, file) = 
              do size <- hFileSize fh
                 printf "%s is %d bytes long.\n" file size


-- @@PLEAC@@_5.13
-- presizing is only useful for mutable maps

-- about performance, one may use Map.IntMap when the keys are Int


-- @@PLEAC@@_5.14
-- 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

s = encode $ sort "Apple Banana Lemon"
-- => [(' ',2),('A',1),('B',1),('L',1),('a',3),('e',2),('l',1),('m',1),('n',3),('o',1),('p',2)]


-- @@PLEAC@@_5.15
import Data.List

father = [ ("Cain",      "Adam")
         , ("Abel",      "Adam")
         , ("Seth",      "Adam")
         , ("Enoch",     "Cain")
         , ("Irad",      "Enoch")
         , ("Mehujael",  "Irad")
         , ("Methusael", "Mehujael")
         , ("Lamech",    "Methusael")
         , ("Jabal",     "Lamech")
         , ("Jubal",     "Lamech")
         , ("Tubalcain", "Lamech")
         , ("Enos",      "Seth")
         ]

upline person = person : parents
    where parents = unfoldr (\name -> fmap (\x -> (x,x)) $ lookup name father) person
-- you can replace (\x -> (x,x)) with (join (,))   ("join" is from Control.Monad)

from_Irad = upline "Irad"       -- ["Irad","Enoch","Cain","Adam"]

ifNull default_ [] = default_
ifNull _ l = l

downline person = person ++ " begat " ++ (ifNull "Nobody" $ intercalate ", " $ children)
    where children = map fst $ filter ((== person) . snd) father

to_Tubalcain = downline "Tubalcain" -- Tubalcain begat Nobody
to_Adam      = downline "Adam"      -- Adam begat Cain, Abel, Seth


-- the perl example is doing something quite weird,
-- include_free is the list of files which are not included by other files,
-- but that do include a file.
dir = "/usr/include"
include_free =
    do files <- getDirectoryContents dir
       let h_files = filter (isSuffixOf ".h") files
       file2includes <- mapM get_includes h_files
       -- getting the files that do include something:
       let files_ = map fst $ filter (not . null . snd) file2includes
       -- removing files included by other files:
       return $ files_ \\ (concatMap snd file2includes)
    where get_includes h_file = fmap (with_content h_file) (readFile $ dir ++ "/" ++ h_file)
          with_content h_file content = (h_file, content_to_includes content)
          content_to_includes = catMaybes . map (fmap head . matchRegex regex) . lines
          regex = mkRegex "^\\s*#\\s*include\\s*<([^>]+)>"


-- @@PLEAC@@_5.16
import Data.Ord (comparing)
import qualified Data.Tree as Tree

dirname_basename file = (if dir == "" then "." else (reverse $ tail dir), reverse base)
    where (base, dir) = break (== '/') $ reverse file

dirname = fst . dirname_basename
basename = snd . dirname_basename

duProcessFakedInput = 
    "11732   groovysoap/lib\n\
    \68      groovysoap/src/main/groovy/net/soap\n\
    \71      groovysoap/src/main/groovy/net\n\
    \74      groovysoap/src/main/groovy\n\
    \77      groovysoap/src/main\n\
    \9       groovysoap/src/examples\n\
    \8       groovysoap/src/examples/groovy\n\
    \102     groovysoap/src/test\n\
    \202     groovysoap/src\n\
    \11966   groovysoap\n"

sortByKeyRev f = map snd . sortBy (flip $ comparing fst) . map (\x -> (f x, x))

dirs_tree :: Tree.Tree (String, Int)
dirs_tree = Tree.unfoldTree get_info (last dir2size)
    where get_info (dir, size) = 
              let subdirs = filter ((== dir) . dirname . fst) dir2size in
              ((dir, size), 
               if null subdirs then [] else 
                   sortByKeyRev snd $ subdirs ++ [ (dir ++ "/.", size - sum (map snd subdirs)) ])
          dir2size = map ((\(size:dir:_) -> (dir, read size)) . words) $ lines duProcessFakedInput

t = putStr $ Tree.drawTree$ fmap (\(f,s)-> show s ++ " " ++ basename f) dirs_tree
-- using Tree.drawTree, the result is not as expected, but it's quite nice:
--
-- 11966 groovysoap
-- |
-- +- 11732 lib
-- |
-- +- 202 src
-- |  |
-- |  +- 102 test
-- |  |
-- |  +- 77 main
-- |  |  |
-- |  |  +- 74 groovy
-- |  |  |  |
-- |  |  |  +- 71 net
-- |  |  |  |  |
-- |  |  |  |  +- 68 soap
-- |  |  |  |  |
-- |  |  |  |  `- 3 .
-- |  |  |  |
-- |  |  |  `- 3 .
-- |  |  |
-- |  |  `- 3 .
-- |  |
-- |  +- 14 .
-- |  |
-- |  `- 9 examples
-- |     |
-- |     +- 8 groovy
-- |     |
-- |     `- 1 .
-- |
-- `- 32 .

-- now the exact same solution 
mydraw :: Tree.Tree (String, Int) -> String
mydraw tree = unlines $ drawSubTrees [tree]
  where drawSubTrees [] = []
        drawSubTrees l@(Tree.Node (_,size_max) _ : _) =
            let format = "%" ++ show (length $ show size_max) ++ "s %s" in
            let draw_one (Tree.Node (name, size) sub) =
                    let name' = basename name in
                    printf format (show size) name' :
                           map (\s -> printf format "|" (map (\_ -> ' ') name') ++ s) (drawSubTrees sub) in
            concatMap draw_one l

t2 = putStr $ mydraw dirs_tree

--11966 groovysoap
--    |           11732 lib
--    |             202 src
--    |               |    102 test
--    |               |     77 main
--    |               |      |     74 groovy
--    |               |      |      |       71 net
--    |               |      |      |        |    68 soap
--    |               |      |      |        |     3 .
--    |               |      |      |        3 .
--    |               |      |      3 .
--    |               |     14 .
--    |               |      9 examples
--    |               |      |         8 groovy
--    |               |      |         1 .
--    |              32 .

-- @@PLEAC@@_6.0
-- for info about the various regexp libraries, see http://haskell.org/haskellwiki/Regular_expressions
--
-- [Oct 2008] Text.Regex.Posix/Text.Regex.Base provides =~ which is quite powerful
-- but it misses simple things like subRegex and splitRegex so in many cases
-- Text.Regex must be used
--
-- with Text.Regex.Posix:
import Text.Regex.Posix
import Text.Regex.Base

meadow = [ "sheeps are ovine", "Sheeps are ovine"
         , "Fine bovines demand fine toreadors."
         , "Muskoxen are polar ovibovine species."
         , "Grooviness went out of fashion decades ago." ]

t1 = filter (=~ "sheep") meadow
-- ["sheeps are ovine"]

t2 = filter (=~ "\\<ovines?") meadow
-- ["sheeps are ovine","Sheeps are ovine"]

-- below require "import Data.Bits" for .|. :
ignoreCase = makeRegexOpts (defaultCompOpt .|. compIgnoreCase) defaultExecOpt
t3 = filter (matchTest $ ignoreCase "sheep") meadow
-- ["sheeps are ovine","Sheeps are ovine"]


-- the same with Text.Regex:
import Data.Maybe
import Text.Regex

t1 = filter (isJust . matchRegex (mkRegex "sheep")) meadow
-- ["sheeps are ovine"]

t2 = filter (isJust . matchRegex (mkRegex "\\<ovines?")) meadow
-- ["sheeps are ovine","Sheeps are ovine"]

ignoreCase s = mkRegexWithOpts s True False
t3 = filter (isJust . matchRegex (ignoreCase "sheep")) meadow
-- ["sheeps are ovine","Sheeps are ovine"]

-- note that Data.ByteString.Char8 has a few interesting functions,
-- but usually regexps are better
import qualified Data.ByteString.Char8 as B

t = filter is_sheep meadow
    where is_sheep s = B.isInfixOf (B.pack "sheep") (B.pack s)
-- ["sheeps are ovine"]


s1 = subRegex (mkRegex "o+") "good food" "e"
-- ged fed 

-- the following helper functions are useful
subRegexWith re new s =
    case matchRegexAll re s of
      Nothing -> s
      Just (before, matched, after, _) -> before ++ new matched ++ (subRegexWith re new after)
subRegexOnceWith re new s = 
    case matchRegexAll re s of
      Nothing -> s
      Just (before, matched, after, _) -> before ++ new matched ++ after

s2 = subRegexOnceWith (mkRegex "o+") (\_ -> "e") "good food" 
-- ged food


digits = "123456789";
l = digits =~ "..." :: [String] -- nb: in List context, calls matchAll
-- ["123","456","789"]

-- for overlapping matches, one must do it by hand:
allOverlappingMatches re s = 
    case matchRegexAll re s of
      Nothing -> []
      Just (before, matched, after, _) -> matched : allOverlappingMatches re (tail matched ++ after)

l = allOverlappingMatches (mkRegex "...") digits
-- ["123","234","345","456","567","678","789"]


string = "And little lambs eat ivy"
(before, matched, after) = string =~ "l[^s]*s" :: (String, String, String)
s = printf "(%s) (%s) (%s)" before matched after :: String
-- "(And ) (little lambs) ( eat ivy)"

-- @@PLEAC@@_6.1
-- copying is the default in pure languages :)
import Text.Regex
import System.Environment
import System.FilePath.Posix

prog_ = subRegex (mkRegex ".*/") "/etc/foo" ""
-- "foo"
-- but it's much nicer to use takeFileName
prog__ = takeFileName "/etc/foo"
-- "foo"

-- as for the program basename, it is:
prog = getProgName


manpage = "/usr/man/man3/foo.1"
catpage = subRegexMatchesWith (mkRegex "man([0-9])") (\[n] -> "cat" ++ n) manpage
-- /usr/man/cat3/foo.1

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

bindirs = [ "/usr/bin", "/bin", "/usr/local/bin" ]
libdirs = map (\s -> subRegex (mkRegex "bin$") s "lib") bindirs

-- @@PLEAC@@_6.2
is_pure_alphabetic = isJust . matchRegex (mkRegex "^[A-Za-z]+$")
is_pure_alphabetic_ = all isLetter -- this handles unicode (accents...)

some_words = [ "silly", "random!stuff#here", "façade", "tschÃŒÃ", "niño", "ÑÑÑÑкОй" ]
l1 = filter is_pure_alphabetic some_words -- ["silly"]
l2 = filter is_pure_alphabetic_ some_words -- all except "random!stuff#here"

-- @@PLEAC@@_6.3
-- "\\S+"         -- as many non-whitespace bytes as possible
-- "[A-Za-z'-]+"  -- as many letters, apostrophes, and hyphens
-- 
-- "\\<([A-Za-z]+)\\>" -- usually best
-- "\\s([A-Za-z]+)\\s" -- fails at ends or w/ punctuation

-- words is similar to splitting on "\s+"
l = words "A text   with some\tseparator\n"
-- ["A","text","with","some","separator"]
--
-- (nb: spaces at beginning or end do not change the result)

-- @@PLEAC@@_6.4
-- Commenting Regular Expressions
-- since regexps are simple strings, you can concatenate regexp pieces:
re = "#"          -- a pound sign
     ++ "(\\w+)"  -- the variable name
     ++ "#"       -- another pound sign
expand_macro vals = subAllRegexMatchesWith (mkRegex re) get_val
    where get_val [s] = fromJust (lookup s vals)
s = expand_macro [ ("foo", "42") ] "blah #foo# blah"
-- "blah 42 blah"

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

-- @@PLEAC@@_6.5
fishes = "One fish two fish red fish blue fish"

-- first some very simple and useful functions:
ignoreCase s = mkRegexWithOpts s True False
allMatches re s =
    case matchRegexAll re s of
      Nothing -> []
      Just (_before, _, after, matches) -> matches : allMatches re after

-- here we go:
colors = map head $ allMatches (ignoreCase "(\\w+)\\s+fish\\>") fishes
-- ["One","two","red","blue"]
s1 = printf "The third fish is a %s one." (colors !! 2) :: String
-- The third fish is a red one.

-- another solution to skip the first 2 matches using an ad'hoc regexp:
s2 = printf "The third fish is a %s one." color :: String
    where Just (_, _, _, [_, color]) = 
              matchRegexAll (ignoreCase "(\\w+\\s+fish\\s+){2}(\\w+)\\s+fish") fishes
-- The third fish is a red one.

-- a modified subRegex to be able to handle differently the 4th match
subRegexWithEnv re f env s =
    case matchRegexAll re s of
      Nothing -> s
      Just (before, matched, after, matches) -> before ++ matched' ++ (subRegexWithEnv re f env' after)
          where (env', matched') = f env (matched:matches)

s3 = subRegexWithEnv (ignoreCase "(\\w+)(\\s+fish\\>)") f 1 fishes
    where f n [verbatim, _, fish] = (n+1, if n == 4 then "sushi" ++ fish else verbatim)
-- One fish two fish red fish sushi fish

-- note that we can easily specialize subRegexWithEnv into subRegexWithCount:
withCountEnv f g s = f (\n val -> (n+1, g n val)) 1 s
subRegexWithCount re = withCountEnv (subRegexWithEnv re)

s3' = subRegexWithCount (ignoreCase "(\\w+)(\\s+fish\\>)") f fishes
    where f n [verbatim, _, fish] = if n == 4 then "sushi" ++ fish else verbatim
-- One fish two fish red fish sushi fish

-- adding .* at beginning of the regexp will ensure we get the last hit.
-- but we must be carefull ".*(\\w+)\\s+fish\\>" is wrong since .* will match
-- most the color, so \\< is also needed
s4 = case matchRegex (ignoreCase ".*\\<(\\w+)\\s+fish\\>") fishes of
     Just [last_fish_color] -> printf "Last fish is %s." last_fish_color
     _ -> "Failed!"
-- Last fish is blue.

-- @@PLEAC@@_6.6
-- for multi line regexps, use (mkRegexWithOpts _ False _)
#!/usr/bin/runghc

-- killtags - very bad html tag killer
import System
import Text.Regex

main = do s <- getArgs >>= any_input
          putStr (strip_tags s)

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

strip_tags s = subRegex (mkRegexWithOpts "<[^>]*>" False True) s ""

-- testing it:
test = "<a>after a\n\
       \<bbb\n\
       \bbb>after b <c>after c\n"
s = strip_tags test
-- "after a\n<bbb\nbbb>after b after c\n"

-- @@PLEAC@@_6.7
-- Read the whole file and split
l1 = fmap lines (readFile filename) -- on line ends
l2 = fmap words (readFile filename) -- on whitespace
l3 = fmap (splitRegex $ mkRegex "PATTERN") (readFile filename) -- on regexp

-- .Ch, .Se and .Ss divide chunks
f = splitRegex (mkRegex "^\\.(Ch|Se|Ss)$")

-- note that in the example above, you loose the matched line,
-- if you need it, you must create your own splitRegex:
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)

-- it uses this special unfoldr
-- (unfoldr only returns [b] whereas we also need the rest)
-- nb: with Control.Arrow.first which is \f (a,b) -> (f a, b)
--     we could 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)

unwords_keeping_spaces = splitRegex' (mkRegex "\\s+")
t = unwords_keeping_spaces "a b  c \t d"
-- [("a"," "),("b","  "),("c"," \t "),("d","")]

-- @@PLEAC@@_6.8
import Text.Regex
import Text.Regex.Posix
import Data.Maybe
import Text.Printf
import System

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

-- command-line to print lines 15 through 17 inclusive (see below)
main = do s <- getArgs >>= any_input
          putStr (unlines $ take 3 $ drop 14 $ lines s)

filterByRange :: (a -> Bool) -> (a -> Bool) -> [a] -> [[a]]
filterByRange _ _ [] = []
filterByRange f_beg f_end l = 
    let l' = dropWhile (not . f_beg) l in
    case break f_end l' of
      (before, match : l'') -> (before ++ [match]) : filterByRange f_beg f_end l''
      _ -> []

extract_XMP :: [String] -> [[String]]
extract_XMP = filterByRange (=~ "<XMP>") (=~ "</XMP>")

t1 = do s <- readFile "foo.html"
        return $ extract_XMP $ lines s

ignoreCase s = mkRegexWithOpts s True False
extract_XMP' = filterByRange (match "<XMP>") (match "</XMP>")
    where match re = isJust . matchRegex (ignoreCase re)

t1' = do s <- readFile "foo.html"
         return $ extract_XMP' $ lines s

mbox_to_headers = filterByRange (match "^From:?\\s") (match "^$")
    where match re = isJust . matchRegex (ignoreCase re)
mail_adresses = concatMap search_in_line
    where search_in_line line = (line =~ "[^<>(),;[:space:]]+@[^<>(),;[:space:]]+") :: [String]
          -- nb: in List context, calls matchAll.
          -- nb: \s can not be used, so instead of [^<>\s], one must do [^<>[:space:]]

t2 = do s <- readFile "mbox"
        return $ mail_adresses $ concat $ mbox_to_headers $ lines s

-- @@PLEAC@@_6.9
import List
import Data.Maybe

special_chars = ".()+*?[]\\{}$^|"

regex_escape_char :: Char -> String
regex_escape_char c = if elem c special_chars 
               then ['\\', c] 
               else [c]
regex_escape :: String -> String
regex_escape = concatMap regex_escape_char

glob_list = 
    [ ('*', ".*")
    , ('?', ".")
    , ('[', "[")
    , (']', "]") ]
glob_char_to_regexp c = fromMaybe (regex_escape_char c) (lookup c glob_list)
-- nb: fromMaybe will try (lookup ...) first, then fallback on (regex_escape_char c)

glob2pat = concatMap glob_char_to_regexp

pat = glob2pat "*File.*"
-- ".*File\\..*"

-- @@PLEAC@@_6.10
import Data.List
import Data.Maybe
import Text.Regex

popstates = ["CO","ON","MI","WI","MN"]

is_state = isJust . matchRegex re
    where re = mkRegex $ "\\<(" ++ intercalate "|" popstates ++ ")\\>"

l = filter is_state [ "xxx", "xx CO xx", "WI", "WIxx" ]
-- ["xx CO xx","WI"]

-- this is less efficient:
is_state' line = any (\re -> isJust $ matchRegex re line) (map to_regexp popstates)
    where to_regexp c = mkRegex $ "\\<" ++ c ++ "\\>"

-- @@PLEAC@@_6.11
import Data.Maybe
import Data.List
import Text.Regex.Base
import Text.Regex.Posix

-- one can not catch invalid patterns using Text.Regex

-- recent versions of Text.Regex.Base have makeRegexM:
is_valid_pattern :: String -> Bool
is_valid_pattern re = isJust (makeRegexM re :: Maybe Regex)
-- nb: the type Regex must be specified since matchRegexM uses abstract
--     classes and haskell can't guess which instance to use

-- or can use compile from Text.Regex.Posix.String:
t = let regexp = "(" in
    compile defaultCompOpt defaultExecOpt regexp >>=
      (\re -> case re of
                Left (_, err) -> error ("bad regexp \"" ++ regexp ++ "\": " ++ err)
                Right re -> return re)
-- *** Exception: bad regexp "(": Unmatched ( or \(

-- @@PLEAC@@_6.12
-- Text.Regex and Text.Regex.Posix do not handle unicode (accents...)

-- @@PLEAC@@_6.13
import Data.List

-- Calculates the Levenshtein, or edit distance, between two strings.
-- here is a basic/slow version:
levenshtein_basic s t = distance (length s) (length t)
    where distance i 0 = i
          distance 0 j = j
          distance i j = minimum [ distance (i-1) j + 1
                                 , distance i (j-1) + 1
                                 , distance (i-1) (j-1) + (if s!!(i-1)==t!!(j-1) then 0 else 1) ]

-- a fast version based on the previous one, adding memoization
-- (note the recursive use of "d")
levenshtein s t = d
    where d = [ [distance m n | n<-[0..length t]] | m<-[0..length s] ]
          distance i 0 = i
          distance 0 j = j
          distance i j = minimum [ d!!(i-1)!!j + 1
                                 , d!!i!!(j-1) + 1
                                 , d!!(i-1)!!(j-1) + (if s!!(i-1)==t!!(j-1) then 0 else 1) ]

-- a more efficient/cryptic version.
-- (it computes the "distance" figures for each "sb" chars,
--  ie it memoizes only what is needed)
levenshtein' sa sb = foldl transform [0..length sa] sb 
    where 
      transform xs@(x:xs') c = scanl compute (x+1) (zip3 sa xs xs')
          where
            compute z (c', x, y) = minimum [y+1, z+1, x + if c == c' then 0 else 1]

-- Determines if two strings are an approximate match.
amatch percentage s t = levenshtein s t * 100 <= percentage * length s

main = do s <- readFile "/usr/share/dict/words"
          print $ filter (amatch 20 "balast") (lines s)
-- ["balant","balas","balat","ballast","belast","blast"]

-- @@PLEAC@@_6.14
import List
import Text.Regex
import Text.Regex.Posix
import Text.Printf

allMatches re = unfoldr (fmap adjust . matchRegexAll re)
    where adjust (_before, _, after, matches) = (matches, after)

-- special unfoldr (unfoldr only returns [b] whereas we also need the rest)
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)

allMatches' re = unfoldr' (fmap adjust . matchRegexAll re)
    where adjust (_before, _, after, matches) = (matches, after)

t = allMatches (mkRegex "([0-9]+)") "3,4,5,9,120"
-- [["3"],["4"],["5"],["9"],["120"]]
-- (note that \d is not special, one must use [0-9] or [[:digit:]])

mystr = "The year 1752 lost 10 days on the 3rd of September"
t2 = 
    let (l, remain) = allMatches' (mkRegex "([0-9]+)") mystr in
    let after = remain =~ "\\S+" :: String in
    putStr $ unlines $ map (\[n] -> "Found number " ++ n) l ++ 
                        [ printf "Found %s after the last number" after ]
    
-- Found number 1752
-- Found number 10
-- Found number 3
-- Found rd after the last number


-- @@PLEAC@@_APPENDIX
import List
import Data.Ord (comparing)
import qualified Data.Array as Array
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Control.Arrow as Arrow

listToArray :: [a] -> Array Int a
listToArray l = Array.listArray (0, length l - 1) l

indexOf subst s = findIndex (subst `isPrefixOf`) (tails s)

groupNelem :: Int -> [a] -> [[a]]
groupNelem n = unfoldr f
    where f [] = Nothing
          f s = Just (splitAt n s)

sortByKey f = map snd . sortBy (comparing fst) . map (\x -> (f x, x))
sortByKeyRev f = map snd . sortBy (flip $ comparing fst) . map (\x -> (f x, x))

-- alike python's fileinput.input() or perl's <>
-- typical usage: getArgs >>= any_input
any_input :: [FilePath] -> IO String
any_input [] = getContents
any_input (f:_) = readFile f

-- subRegex only allow a fixed string
-- subRegexWith below takes a (String -> String) function to compute a result
subRegexWith re new s =
    case matchRegexAll re s of
      Nothing -> s
      Just (before, matched, after, _) -> before ++ new matched ++ (subRegexWith re new after)

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

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

dirname_basename file = (if dir == "" then "." else (reverse $ tail dir), reverse base)
    where (base, dir) = break (== '/') $ reverse file

dirname = fst . dirname_basename
basename = snd . dirname_basename


-- from http://www.cse.unsw.edu.au/~dons/code/newpopen
-- modified to handle stderr
import System.Process
import System.Exit
import System.IO

import Control.Monad
import Control.Concurrent
import qualified Control.Exception as C

readProcess :: FilePath                     -- ^ command to run
            -> [String]                     -- ^ any arguments
            -> String                       -- ^ standard input
            -> IO (Either ExitCode String)  -- ^ either the stdout, or an exitcode

readProcess cmd args input = C.handle (return . handler) $ do

    (inh,outh,errh,pid) <- runInteractiveProcess cmd args Nothing Nothing

    -- fork off a thread to start consuming the output
    output  <- hGetContents outh
    outMVar <- newEmptyMVar
    forkIO $ C.evaluate (length output) >> putMVar outMVar ()

    -- fork off a thread to start consuming the output
    errput  <- hGetContents errh
    errMVar <- newEmptyMVar
    forkIO $ C.evaluate (length errput) >> putMVar errMVar ()

    -- now write and flush any input
    when (not (null input)) $ hPutStr inh input
    hClose inh          -- done with stdin

    -- wait on the output
    takeMVar outMVar
    hClose outh

    -- wait on the errput
    takeMVar errMVar
    hClose errh

    hPutStr stderr errput

    -- wait on the process
    ex <- C.catch (waitForProcess pid) (\_ -> return ExitSuccess)

    return $ case ex of
        ExitSuccess   -> Right output
        ExitFailure _ -> Left ex

  where
    handler (C.ExitException e) = Left e
    handler e                   = Left (ExitFailure 1)