----------------------------------------
-- Short Applications in Haskell
-- Fritz Ruehr, Willamette University, October 2001
-- For the 3rd Annual CCSC Northwest Conference
----------------------------------------

--------------------
-- Simple text processing

shout = map toUpper

-- > shout "hey! this SHOULD be lOuD!"
-- "HEY! THIS SHOULD BE LOUD!"

-- titling capitalizes initial letters of all words

title = unwords . map cap . words

cap [] = []
cap (x:xs) = toUpper x : map toLower xs

-- > title "from HERE to eTERNity ... And bAcK"
-- "From Here To Eternity ... And Back"


--------------------
-- Basic ROT-13 utility

-- apply f to every element satisfying p

mapon p f = map (\x -> if p x then f x else x)

-- apply numeric function to (offset) chars

relative n f = chr . (+n) . f . (\k->k-n) . ord

-- shift alphabetics by k, relative to start char

shift k a = relative (ord a) ((`mod` 26) . (+k))

rot n = mapon isUpper (shift n 'A') . 
        mapon isLower (shift n 'a')


--------------------
-- Simple command-line user interaction

bylines g = unlines . g . lines
tilEmpty = takeWhile (not . null)

-- adjust the standard "interact" utility function 
-- for line-by-line, null-terminated behavior

interline f = interact (bylines (map f . tilEmpty))

demo title f = 
  do putStrLn  ("\nWelcome to the " ++ title)
     putStrLn  "(one input per line, <CR> to quit)\n"
     interline (prompt f)
     putStrLn  ("Thanks for trying the " ++ title)
        where prompt f x = "--> " ++ f x ++ "\n"


--------------------
-- Palindrome checker

-- normalizer, palindrome predicate, test data

normalize = map toLower . filter isAlpha

palindrome s = (n == reverse n)
               where n = normalize s

adam  = "Madam, in Eden, I'm Adam."
canal = "A man, a plan, a canal ... Panama!"

-- interactive checker based on demo generator

paldemo = 
  demo "palindrome checker" (show . palindrome)


--------------------
-- Base conversions for numerals

unfoldl p f a x = if p x then a else unfoldl p f (y:a) r
                  where (r,y) = f x

sumProd b n m = n * b + m

contract b = foldl          (sumProd b)  0
expand   b = unfoldl (==0) (`divMod` b) []

number b = contract b . map digitToInt
string b = map intToDigit  .  expand b

[ (bin, unbin), (dec, undec), (hex, unhex) ] 
  = map base [2, 10, 16]
    where base b = (string b, number b)


--------------------
-- Binary trees, traversal and treesort

data BTree a = Tip | Node a (BTree a) (BTree a)

fold t n  Tip         = t
fold t n (Node a l r) = n a (fold t n l) (fold t n r)

inorder = fold [] (\x l r -> l ++ x : r)

ins x  Tip = Node x Tip Tip
ins x (Node y l r) | x <= y    = Node y (ins x l) r
                   | otherwise = Node y l (ins x r)

buildtree :: Ord a => [a] -> BTree a
buildtree = foldr ins Tip

treesort :: Ord a => [a] -> [a]
treesort = inorder . buildtree


--------------------
-- Definition and simulation of DFAs

newtype (Eq s, Eq a) =>     -- state & alphabet symbols
  DFA s a = DFA ([s],       -- ¥ set of states
                 [a],       -- ¥ input alphabet
                  s->a->s,  -- ¥ transition function
                  s,        -- ¥ initial state
                 [s])       -- ¥ final states

checkDFA (DFA (qs, sig, d, q, f))
  = all (`elem` qs) 
        (q : f ++ [ d q a | q <- qs, a <- sig ])

runDFA m@(DFA (qs, sig, d, q, f)) str 
  = if checkDFA m then elem (foldl d q str) f 
                  else error "bad DFA"


--------------------
-- Sample DFA and runs

-- M1 from Sipser text (p. 36):   

m1 = DFA ([1..3], "ab", delta, 1, [2])
     where delta 1 'a' = 1
           delta 1 'b' = 2
           
           delta 2 'a' = 3
           delta 2 'b' = 2
           
           delta 3 'a' = 2
           delta 3 'b' = 2

-- > map (runDFA m1) ["a", "b", "ab", "ba", "bab"]
-- [False, True, True, False, True]


--------------------
-- End of file
--------------------