sandbox.hs

-- Learn you a Haskell for Great Good --
-- GIST: 4e3241f2a73fe93d7a96

import Data.List
import Data.Char
import qualified Data.Map as Map

-- head, tail, take, drop, takeWhile, dropWhile
-- fst, snd, zip, zipWith, flip
-- sum, product, maximum

sum2 :: Int -> Int -> Int
sum2 a b = a + b

-- pattern matching on Ints
factorial :: Int -> Int
factorial 0 = 1
factorial n = n * factorial (n-1)

-- pattern matching on tuples
addTuples :: (Double, Double) -> (Double,Double) -> (Double, Double)
addTuples (a,b) (c,d) = (a + c, b + d)

-- pattern matching on lists
head' :: [a] -> a
head' [] = error "cannot give head"
head' (x:_) = x

-- class constraints
tell :: (Show a) => [a] -> String
tell [] = "empty string"
tell (x:[]) = "list is one item " ++ show x
tell (x:y:_) = "list is more than one item, first two items are " ++ show x ++ " and " ++ show y

-- guards (replacements for big if/else conditions) + where + function body
bmiTell :: Double -> String
bmiTell bmi
  | bmi <= 18.5 = "Underweigth"
  | bmi <= 25.0 = "Normal"
  | bmi <= 30.0 = "Overweigth"
bmiTell bmi = "You are Obese " ++ show doubleBmi
  where doubleBmi = bmi * 2

-- where w/ pattern matching
initial :: String -> String -> (Char, Char)
initial firstName lastName = (f, l)
  where (f:_) = firstName
        (l:_) = lastName

-- case expression
head'' :: [a] -> a
head'' xs = case xs of [] -> error "cannot give head"
                       (x:_) -> x
-- recursion
fibonacci :: Int -> Int
fibonacci 0 = 0
fibonacci 1 = 1
fibonacci n = fibonacci (n-1) + fibonacci (n-2)

-- sequence
--let fibonacciSeq = [fibonacci x | x <- [2..12]]

-- recursion
maximum' :: (Ord a) => [a] -> a
maximum' [] = error "empty list"
maximum' [x] = x
maximum' (x:xs) = max x (maximum' xs)

-- recursion
replicate' :: Int -> a -> [a]
replicate' 0 _ = []
replicate' 1 x = [x]
replicate' n x =  x : replicate' (n-1) x

-- use guards instead of patterns b/c we're testing for a boolean condition
replicate'' :: Int -> a -> [a]
replicate'' n x
  | n <= 0 = []
  | otherwise = x : replicate'' (n-1) x

take' :: Int -> [a] -> [a]
take' n _
  | n <= 0 = []
take' _ [] = []
take' n (x:xs) = x : take' (n-1) xs

zip' :: [a] -> [b] -> [(a,b)]
zip' [] _ = []
zip' _ [] = []
zip' (x:xs) (y:ys) = (x,y) : zip' xs ys

elem' :: (Eq a) => a -> [a] -> Bool
elem' x [] = False
elem' x (y:ys) = x == y || elem' x ys

quicksort' :: (Ord a) => [a] -> [a]
quicksort' [] = []
quicksort' (x:[]) = [x]
quicksort' (x:xs) = let smaller = quicksort' [l | l <- xs, l < x]
                        largerOrEqual = quicksort' [g | g <- xs, g >= x]
                    in smaller ++ x : largerOrEqual

-- curried functions
isAlpha :: Char -> Bool
isAlpha = (`elem` ['A'..'Z'])

applyTwice :: (a->a) -> a -> a
applyTwice f x = f (f x)

zipWith' :: (a->b->c) -> [a] -> [b] -> [c]
zipWith' _ [] _ = []
zipWith' _ _ [] = []
zipWith' f (x:xs) (y:ys) = f x y : zipWith' f xs ys


flip' :: (a -> b -> c) -> b -> a -> c
flip' f x y = f y x

-- common higher-order functions
map' :: (a -> b) -> [a] -> [b]
map' _ [] = []
map' f (x:xs) = f x : map' f xs

filter' :: (a -> Bool) -> [a] -> [a]
filter' f xs = [y | y <- xs, f y]

--find sum of all odd squares that are smaller than 10,000
--sum (takeWhile (<10000) (filter odd (map (^2) [1..])))

-- collatz sequences
collatz :: Integer -> [Integer]
collatz 1 = [1]
collatz n
  | even n = n:collatz (n `div` 2)
  | odd n = n:collatz (n * 3 + 1)

-- find # of chains larger than 15 for numbers between 1 and 100
--length (filter (>15) (map length (map collatz [1..100])))
--length (filter (\xs -> length xs > 15) (map collatz [1..100]))

--foldl' :: (a->b->a) -> a -> [b] -> a
--foldr' :: (a->b->b) -> b -> [a] -> b

reverse' :: [a] -> [a]
reverse' = foldl (\acc x -> x : acc) []

-- function composition
--replicate 2 (product (map (*3) (zipWith max [1,2] [4,5])))
--replicate 2 . product . map (*3) $ zipWith max [1,2] [4,5]

digits :: (Integral a) => a -> [a]
digits n
  | n < 10 = [n]
  | otherwise = digits (n `quot` 10) ++ [n `mod` 10]

-- (length $ takeWhile (/=40) $ map (foldl1 (+)) $ map digits [1..]) + 1


-- dictionaries
--
findByKey :: (Eq k) => [(k,v)] -> k -> Maybe v
findByKey [] key = Nothing
findByKey ((k,v):xs) key
  | key == k = Just v
  | otherwise = findByKey xs key

-- Map.fromList
-- Map.fromListWith
-- Mat.lookup
-- Mat.insert
-- Map.size
--

-- data types
data MyType = MyValueConstructor1 Int | MyValueConstructor2 Float
  deriving (Show)

data SingleValueConstructor = SingleValueConstructor
  deriving (Show)

data MyRecord = MyRecord {
    name :: String,
    age :: Int
  } deriving (Show)

-- MyRecord "Antonio" 31
-- MyRecord {age=31, name="Antonio"}

-- value constructors are "tags" used to build new instances of the data (type) and pattern match them
data MyTypeConstructor a = MyOtherValueConstructor1 a | MyOtherValueConstructor2 a
  deriving (Show)

myFunction :: (MyTypeConstructor a) -> (MyTypeConstructor a)
myFunction (MyOtherValueConstructor1 n) = MyOtherValueConstructor2 n
myFunction (MyOtherValueConstructor2 n) = MyOtherValueConstructor1 n

-- pattern matching is all about value constructors (including data structures which are
-- simply syntactic sugar for value constructors anyway)

-- type aliases
type MyString = String

-- binary search tree

data Tree a = EmptyTree | Node a (Tree a) (Tree a) deriving (Show,Eq)

singleton :: a -> Tree a
singleton v = Node v EmptyTree EmptyTree

treeInsert :: (Ord a) => a -> Tree a -> Tree a
treeInsert v EmptyTree = singleton v
treeInsert v (Node n left right)
  | v < n = Node n (treeInsert v left) right
  | v > n = Node n left (treeInsert v right)
  | otherwise = Node v left right

treeElem :: (Ord a) => a -> Tree a -> Bool
treeElem _ EmptyTree = False
treeElem v (Node n left right)
  | v == n = True
  | v < n = treeElem v left
  | v > n = treeElem v right

-- type classes
class MyClass a where
  something :: a -> [a]

instance MyClass (Tree a) where
  something EmptyTree = [EmptyTree]
  something (Node v _ _) = [Node v EmptyTree EmptyTree]

class YesNo a where
  yesno :: a -> Bool

instance YesNo Int where
  yesno 0 = False
  yesno _ = True

instance YesNo [a] where
  yesno [] = False
  yesno _ = True

instance YesNo Bool where
  yesno = id

-- functor
-- f is a type constructor with a single type parameter, not a concrete type!!!!!!
class Functor' f where
  fmap' :: (a -> b) -> f a -> f b

instance Functor' Maybe where
  fmap' _ Nothing = Nothing
  fmap' f (Just a) = Just (f a)

instance Functor' [] where
  fmap' = map

instance Functor' Tree where
  fmap' _ EmptyTree = EmptyTree
  fmap' f (Node v left right) = Node (f v) (fmap' f left) (fmap' f right)

-- first law of functors
-- fmap' id t == id t
-- second law of functors
-- fmap' ((+3) . (*4)) t == ((fmap' (+3)) . (fmap' (*4))) t
--

instance Functor' IO where
  fmap' f action = do
    original <- action
    return (f original)

-- partially apply type constructor to obtain one with a single type parameter
instance Functor' (Either a) where
  fmap' f (Right x) = Right (f x)
  fmap' _ (Left x ) = Left x

instance Functor' (Map.Map k) where
  fmap' = Map.map

runDo :: String -> IO ()
runDo a = putStrLn a

--data Tree a = EmptyTree | Node a (Tree a) (Tree a) deriving (Show)

class Applicative' f where
  pure :: a -> f a
  (<*>) :: f (a -> b) -> f a -> f b

instance Applicative' Tree where
  pure a = Node a EmptyTree EmptyTree
  (<*>) _ EmptyTree = EmptyTree
  (<*>) EmptyTree _ = EmptyTree
  (<*>) (Node g _ _) (Node v a b) = (Node (g v) ((<*>) (pure g) a) ((<*>) (pure g) b))

-- let t = foldr treeInsert EmptyTree [1,2,3]
-- let s = singleton (*2)
-- (<*>) s t
-- s <*> t

-- wrong! (incomplete)
-- instance Applicative' [] where
--   pure a = [a]
--   _ <*> [] = []
--   (x:_) <*> (y:ys) = x y:(pure x <*> ys)

-- right
instance Applicative' [] where
  pure a = [a]
  fs <*> xs = [f x | f <- fs, x <- xs]

-- [(+),(*)] <*> [1,2] <*> [3,4]

instance Applicative' IO where
  pure = return
  f <*> x = do
    g <- f -- g is the function yielded by f
    y <- x -- y is the value yielded by x
    return (g y)