-----------------------------------------------------------------------
--
--  Haskell: The Craft of Functional Programming, 3e
--  Simon Thompson
--  (c) Addison-Wesley, 1996-2011.
-- 
--  Chapter 12
--
-----------------------------------------------------------------------

-- For Rock-Paper-Scissors examples see RPS.hs

module Chapter12 where

import Pictures hiding (flipH,rotate,flipV,beside,invertColour,
            superimpose,printPicture)


-- Revisiting the Pictures example, yet again.

flipV :: Picture -> Picture
flipV :: Picture -> Picture
flipV      = ([Char] -> [Char]) -> Picture -> Picture
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> [Char]
forall a. [a] -> [a]
reverse

beside :: Picture -> Picture -> Picture
beside :: Picture -> Picture -> Picture
beside = ([Char] -> [Char] -> [Char]) -> Picture -> Picture -> Picture
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
(++)


-- Revisiting the Picture example
-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^

-- Some of the functions are already (re)defined in this script.
-- Among the other functions mentioned were 

invertColour :: Picture -> Picture
invertColour :: Picture -> Picture
invertColour = ([Char] -> [Char]) -> Picture -> Picture
forall a b. (a -> b) -> [a] -> [b]
map ((Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
invert)

superimpose  :: Picture -> Picture -> Picture
superimpose :: Picture -> Picture -> Picture
superimpose = ([Char] -> [Char] -> [Char]) -> Picture -> Picture -> Picture
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ((Char -> Char -> Char) -> [Char] -> [Char] -> [Char]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Char -> Char -> Char
combineChar)

-- The definition of combineChar is left as an exercise: it's a dummy definition
-- here.

combineChar :: Char -> Char -> Char
combineChar :: Char -> Char -> Char
combineChar = Char -> Char -> Char
combineChar

-- Printing a picture: uses putStr after a newline has been added at the end of
-- every line and the lines are joined into a single string.

printPicture :: Picture -> IO ()
printPicture :: Picture -> IO ()
printPicture = [Char] -> IO ()
putStr ([Char] -> IO ()) -> (Picture -> [Char]) -> Picture -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Picture -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Picture -> [Char]) -> (Picture -> Picture) -> Picture -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> [Char]) -> Picture -> Picture
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
"\n")

-- Regular expressions

type RegExp = String -> Bool

char :: Char -> RegExp

epsilon :: [Char] -> Bool
epsilon = ([Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
==[Char]
"")

char :: Char -> [Char] -> Bool
char Char
ch = ([Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
==[Char
ch])

(|||) :: RegExp -> RegExp ->  RegExp

[Char] -> Bool
e1 ||| :: ([Char] -> Bool) -> ([Char] -> Bool) -> [Char] -> Bool
||| [Char] -> Bool
e2 = 
    \[Char]
x -> [Char] -> Bool
e1 [Char]
x Bool -> Bool -> Bool
|| [Char] -> Bool
e2 [Char]
x

(<*>) :: RegExp -> RegExp ->  RegExp

[Char] -> Bool
e1 <*> :: ([Char] -> Bool) -> ([Char] -> Bool) -> [Char] -> Bool
<*> [Char] -> Bool
e2 =
    \[Char]
x -> [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [ [Char] -> Bool
e1 [Char]
y Bool -> Bool -> Bool
&& [Char] -> Bool
e2 [Char]
z | ([Char]
y,[Char]
z) <- [Char] -> [([Char], [Char])]
forall {a}. [a] -> [([a], [a])]
splits [Char]
x ]

(<**>) :: RegExp -> RegExp ->  RegExp

[Char] -> Bool
e1 <**> :: ([Char] -> Bool) -> ([Char] -> Bool) -> [Char] -> Bool
<**> [Char] -> Bool
e2 =
    \[Char]
x -> [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [ [Char] -> Bool
e1 [Char]
y Bool -> Bool -> Bool
&& [Char] -> Bool
e2 [Char]
z | ([Char]
y,[Char]
z) <- [Char] -> [([Char], [Char])]
forall {a}. [a] -> [([a], [a])]
fsplits [Char]
x ]

splits :: [a] -> [([a], [a])]
splits [a]
xs = [Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
n [a]
xs | Int
n<-[Int
0..Int
len]]
    where
      len :: Int
len = [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs

star :: RegExp -> RegExp

star :: ([Char] -> Bool) -> [Char] -> Bool
star [Char] -> Bool
p = [Char] -> Bool
epsilon ([Char] -> Bool) -> ([Char] -> Bool) -> [Char] -> Bool
||| ([Char] -> Bool
p ([Char] -> Bool) -> ([Char] -> Bool) -> [Char] -> Bool
<**> ([Char] -> Bool) -> [Char] -> Bool
star [Char] -> Bool
p)
--           epsilon ||| (p <*> star p)
-- is OK as long as p can't have epsilon match

fsplits :: [a] -> [([a], [a])]
fsplits [a]
xs = [([a], [a])] -> [([a], [a])]
forall a. HasCallStack => [a] -> [a]
tail ([a] -> [([a], [a])]
forall {a}. [a] -> [([a], [a])]
splits [a]
xs)

--
-- Case studies: functions as data
--

-- Natural numbers as functions.

type Natural a = (a -> a) -> (a -> a)

zero, one, two :: Natural a

zero :: forall a. Natural a
zero a -> a
f = a -> a
forall a. a -> a
id 
one :: forall a. Natural a
one a -> a
f  = a -> a
f 
two :: forall a. Natural a
two a -> a
f  = a -> a
f(a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.a -> a
f

int :: Natural Int -> Int 

int :: Natural Int -> Int
int Natural Int
n = Natural Int
n (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int
0

-- sends representation of n to rep. of n+1

succ :: Natural a -> Natural a
succ :: forall a. Natural a -> Natural a
succ = [Char] -> Natural a -> Natural a
forall a. HasCallStack => [Char] -> a
error [Char]
"succ"

-- sends reps. of n and m to rep. of n+m

plus :: Natural a -> Natural a -> Natural a
plus :: forall a. Natural a -> Natural a -> Natural a
plus = [Char] -> Natural a -> Natural a -> Natural a
forall a. HasCallStack => [Char] -> a
error [Char]
"plus"

-- sends reps. of n and m to rep. of n*m
times :: Natural a -> Natural a -> Natural a
times :: forall a. Natural a -> Natural a -> Natural a
times = [Char] -> Natural a -> Natural a -> Natural a
forall a. HasCallStack => [Char] -> a
error [Char]
"times"

-- Creating an index
-- ^^^^^^^^^^^^^^^^^

-- See Index.hs

-- Development in practice
-- ^^^^^^^^^^^^^^^^^^^^^^^
-- Defining the .. notation (not executable code).
-- 
-- [m .. n]
--   | m>n         = []
--   | otherwise   = m : [m+1 .. n]

-- [1 .. n] 
--   | 1>n         = []
--   | otherwise   = [1 .. n-1] ++ [n]

-- A simple palindrome check.

simplePalCheck :: String -> Bool
simplePalCheck :: [Char] -> Bool
simplePalCheck [Char]
st = ([Char] -> [Char]
forall a. [a] -> [a]
reverse [Char]
st [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
st)

-- The full check

palCheck :: [Char] -> Bool
palCheck = [Char] -> Bool
simplePalCheck ([Char] -> Bool) -> ([Char] -> [Char]) -> [Char] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
clean

-- where the clean function combines mapping (capitals to smalls) and
-- filtering (removing punctuation)

clean :: String -> String 

clean :: [Char] -> [Char]
clean = (Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
forall {t}. t
toSmall ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
filter Char -> Bool
forall {t}. t
notPunct

toSmall :: t
toSmall  = t
toSmall  -- dummy definition
notPunct :: t
notPunct = t
notPunct -- dummy definition

-- Auxiliary functions

-- When is one string a subsequence of another? 

subseq :: String -> String -> Bool

subseq :: [Char] -> [Char] -> Bool
subseq []    [Char]
_  = Bool
True
subseq (Char
_:[Char]
_) [] = Bool
False
subseq (Char
x:[Char]
xs) (Char
y:[Char]
ys)
  = [Char] -> [Char] -> Bool
subseq (Char
xChar -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char]
xs) [Char]
ys Bool -> Bool -> Bool
|| [Char] -> [Char] -> Bool
frontseq (Char
xChar -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char]
xs) (Char
yChar -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char]
ys)

-- When is one strong a subsequece of another, starting at the front?

frontseq :: String -> String -> Bool
frontseq :: [Char] -> [Char] -> Bool
frontseq []     [Char]
_  = Bool
True
frontseq (Char
_:[Char]
_)  [] = Bool
False
frontseq (Char
x:[Char]
xs) (Char
y:[Char]
ys)
  = (Char
xChar -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
y) Bool -> Bool -> Bool
&& [Char] -> [Char] -> Bool
frontseq [Char]
xs [Char]
ys


-- Understanding programs
-- ^^^^^^^^^^^^^^^^^^^^^^

mapWhile :: (a -> b) -> (a -> Bool) -> [a] -> [b]

mapWhile :: forall a b. (a -> b) -> (a -> Bool) -> [a] -> [b]
mapWhile a -> b
f a -> Bool
p []    = [] 
mapWhile a -> b
f a -> Bool
p (a
x:[a]
xs)
  | a -> Bool
p a
x            = a -> b
f a
x b -> [b] -> [b]
forall a. a -> [a] -> [a]
: (a -> b) -> (a -> Bool) -> [a] -> [b]
forall a b. (a -> b) -> (a -> Bool) -> [a] -> [b]
mapWhile a -> b
f a -> Bool
p [a]
xs
  | Bool
otherwise      = [] 

example1 :: [Integer]
example1 = (Integer -> Integer) -> (Integer -> Bool) -> [Integer] -> [Integer]
forall a b. (a -> b) -> (a -> Bool) -> [a] -> [b]
mapWhile (Integer
2Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+) (Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>Integer
7) [Integer
8,Integer
12,Integer
7,Integer
13,Integer
16]