{-# LANGUAGE ExistentialQuantification #-}

-- File: rdm.hs
-- Date: 02/10/2010
-- Author: Collin J. Doering <rekahsoft@gmail.com>
-- Description: Random source file to experiment while learning haskell

import System.IO
import Data.List
import Data.Foldable (foldr')
import Data.Function
import System.Posix.User
import Control.Monad

-- Given a item and a list finds the index's (if any) where the item exist in the list
fp :: a -> [a] -> [Int]
fp y xs = fst $ fp' xs ([],0)
  where fp' [] acc = acc
        fp' (x:xs) (zs,i)
          | x == y = fp' xs (i:zs, i + 1)
          | otherwise = fp' xs (zs, i + 1)

betterFp :: a -> [a] -> [Int]
betterFp y = fst . foldr (\a (xs,i) -> if y == a then (i:xs,i+1) else (xs,i+1)) ([],0)

nameSpam :: IO ()
nameSpam s = putStrLn $ fst $ foldr (\x (a, i) -> (take i (repeat x) ++ a, i - 1)) ("", length s) s

printTriangle :: Char -> Int -> IO ()
printTriangle c i = pTriangle c 1
  where pTriangle c j
          | j > i = return ()
          | otherwise = putStrLn (take j (repeat c)) >>
                        pTriangle c (j + 1)

printTriangle' :: Char -> Int -> IO ()
printTriangle' _ 0 = return ()
printTriangle' c i = putStrLn (take i (repeat c)) >> printTriangle' c (i - 1)

printTriangle'' :: Char -> Integer -> IO ()
printTriangle'' c n = putStrLn $ foldr' (\i a -> (take i $ repeat c) ++ "\n" ++ a) "" [1..n]

factorial :: Integer -> Integer
factorial x = if x <= 1 then 1
              else x * factorial (x - 1)

-- The factorial function using fix points
factorial' = fix (\f x -> if x <= 1 then 1 else x * f(x - 1))

factorial'' = fix (\f acc x -> if x <= 1 then acc else f (acc * x) (x - 1)) 1

factorial1 :: Integer -> Integer
factorial1 0 = 1
factorial1 xs = xs * factorial1 (xs - 1)

squareList :: [Double] -> [Double]
squareList lst = if null lst then []
                 else (square (head lst)):(squareList (tail lst))
                      where square x = x * x

squareList1 :: [Double] -> [Double]
squareList1 [] = []
squareList1 (x:xs) = (square x):(squareList1 xs)
                     where square x = x * x

squareList2 = map (\x -> x * x)

fib :: Integer -> Integer
fib 0 = 0
fib 1 = 1
fib x = fib (x-1) + fib (x-2)

-- Playing with datatypes
data Posn = Posn2D { x :: Int, y :: Int }
          | Posn3D { x :: Int, y :: Int, z :: Int }
          deriving (Show, Eq, Ord)

-- Real World Haskell Exercises
data List a = Cons a (List a)
            | Nil
              deriving (Show)

listToBIL :: List a -> [a]
listToBIL (Cons a xs) = a:(listToBIL xs)
listToBIL Nil = []

myLength :: [a] -> Integer
myLength [] = 0
myLength x = 1 + myLength (drop 1 x)

myLength1 :: [a] -> Integer
myLength1 lst = let myLength1Help [] acc = acc
                    myLength1Help (_:xs) acc = myLength1Help xs (acc + 1)
                in myLength1Help lst 0

myLength2 :: [a] -> Int
myLength2 lst = myLength2' lst 0
  where myLength2' [] a = a
        myLength2' (_:xs) a = myLength2' xs (a + 1)

meanOfList :: [Double] -> Double
meanOfList lst = meanSum lst 0 0
  where meanSum [] s l
          | l /= 0 = s / l
          | otherwise = 0
        meanSum (x:xs) s l = meanSum xs (s + x) (l + 1)

listToPalindrome :: [a] -> [a]
listToPalindrome [] = []
listToPalindrome x = x ++ reverse x

isPalindrome :: (Eq a) => [a] -> Bool
isPalindrome x
  | mod len 2 == 0 && take (div len 2) x == reverse (drop (div len 2) x) = True
  | otherwise                                                            = False
  where len = length x

foldrmap :: (a -> b) -> [a] -> [b]
foldrmap fn = foldr (\x y -> (fn x):y) []
--foldrmap fn = foldr ((:) . fn) []

foldrcopy :: [a] -> [a]
foldrcopy = foldr (:) []

foldrappend :: [a] -> [a] -> [a]
foldrappend a b = foldr (:) b a

foldrlength :: [a] -> Int
foldrlength = foldr (\x y -> y + 1) 0

foldrsum :: (Num a) => [a] -> a
foldrsum = foldr (+) 0

--myfoldr fn init lst = myFoldrHelper ...

myMap :: (a -> b) -> [a] -> [b]
myMap f xs = [f x | x <- xs]

myMap1 :: (a -> b) -> [a] -> [b]
myMap1 _ [] = []
myMap1 f (x:xs) = f x : myMap1 f xs

mapWithFilter :: (a -> b) -> (a -> Bool) -> [a] -> [b]
mapWithFilter f p xs = [f x | x <- xs, p x]

mapWithFilter1 :: (a -> b) -> (a -> Bool) -> [a] -> [b]
mapWithFilter1 _ _ [] = []
mapWithFilter1 f p (x:xs)
  | p x = f x : mapWithFilter1 f p xs
  | otherwise = mapWithFilter1 f p xs

mapWithFilter2 :: (a -> b) -> (a -> Bool) -> [a] -> [b]
mapWithFilter2 f p = map f . filter p

-- A neat little closure
myFlip :: (a -> b -> c) -> b -> a -> c
myFlip f = \a b -> f b a

compose :: (a -> b) -> (c -> a) -> (c -> b)
compose f g = \x -> f(g(x))

disemvowel :: String -> String
disemvowel = unwords . filter p . words
  where p = flip elem "AaEeIiOoUu" . head

-- questions from http://www.haskell.org/haskellwiki/Hitchhikers_guide_to_Haskell
greeter = do
  putStrLn "Hello there! May i ask your name?"
  name <- getLine
  if name == "no"
    then putStrLn "Well, sorry i asked..goodbye!"
    else putStrLn ("Well hello there " ++ name ++ ", it's nice to meet you!")

-- The above greeter "de-sugared"
greeter2 :: IO ()
greeter2 = putStrLn "Hello there! May i ask your name?"
           >> getLine
           >>= \name -> if name == "no"
                        then putStrLn "Well, sorry i asked..goodbye!"
                        else putStrLn ("Well hello there " ++ name ++ ", it's nice to meet you!")

safeHead :: [a] -> Maybe a
safeHead [] = Nothing
safeHead (x:xs) = Just x

myTail :: [a] -> [a]
myTail [] = []
myTail (_:xs) = xs

-- Old version..why not make it for all monads?
-- myLiftM :: (a -> b) -> IO a -> IO b
-- myLiftM f a = a >>= \x -> return (f x)

{-  Here is a generic version of myLiftM, which has the same behavior as liftM. 
    Though the standard library chose to use do notation rather then the monadic
    bind function (>>=), they are actually the same once the do notation is
    de-sugared. Finally, notice the only thing that got changed here was the type
    signature.
-}
myLiftM :: Monad m => (a -> b) -> m a -> m b
myLiftM f a = a >>= \x -> return (f x)

--nthDigit :: Integer -> Integer -> Integer
--nthDigit n i = floor(10 * (f - floor(f)))
--  where f = n/10^(i+1)

-- Implementation of a Maybe like type
data Perhaps a = PNone
               | PJust a
               deriving (Eq,Ord,Show)

instance Functor Perhaps where
  fmap _ PNone = PNone
  fmap f (PJust x) = PJust (f x)

instance Monad Perhaps where
  (PJust a) >>= f = f a
  PNone >>= _ = PNone
  
  return a = PJust a

instance MonadPlus Perhaps where
  mzero = PNone
  
  mplus (PJust a) _ = PJust a
  mplus PNone (PJust a) = PJust a
  mplus _ _ = PNone

-- Simple Binary Tree type
data Tree a = Empty
            | Node a (Tree a) (Tree a)
            deriving (Show, Eq)

instance Ord m => Ord (Tree m) where
  _ >= Empty = True
  (Node a _ _) >= (Node b _ _) = a >= b
  _ >= _ = False
  
  _ <= Empty = True
  (Node a _ _) <= (Node b _ _) = a <= b
  _ <= _ = False

leaf :: a -> Tree a
leaf x = Node x Empty Empty

balanced :: Ord a => Tree a -> Bool
balanced Empty = True
balanced nd@(Node _ ls rs) = nd >= ls && nd <= rs && balanced ls && balanced rs

depth :: Tree a -> Int
depth Empty = 0
depth (Node _ ls rs) = 1 + max (depth ls) (depth rs)

-- A parser type
type Parser a = String -> [(a,String)]

-- Questions from Book "Programming in Haskell"
-- Excercises 5.8

-- Given an even list returns a pair of its halves
halve :: [a] -> ([a],[a])
halve xs
  | length xs `mod` 2 == 0 = (take halfLen xs, drop halfLen xs)
  | otherwise              = ([],[])
  where halfLen = (length xs `div` 2)
        
safeTailA :: [a] -> [a]
safeTailA xs = if null xs then [] else tail xs

safeTailB :: [a] -> [a]
safeTailB xs
  | null xs = []
  | otherwise = tail xs

safeTailC :: [a] -> [a]
safeTailC [] = []
safeTailC (x:xs) = xs

-- Did a version using the Maybe type for entertainment
safeTail :: [a] -> Maybe [a]
safeTail [] = Nothing
safeTail (x:xs) = Just xs

myReplicate :: Int -> a -> [a]
myReplicate i e = [x | _ <- [1..i], x <- [e]]

pythagoreans :: Int -> [(Int,Int,Int)]
pythagoreans i = [(x,y,z) | x <- [1..i], y <- [1..i], z <- [1..i], x^2 + y^2 == z^2]

scalarProduct :: [Int] -> [Int] -> Int
scalarProduct xs ys = sum [x * y | (x,y) <- zip xs ys]

-- Excercise 7.8
toPowerOf :: Int -> Int -> Int
x `toPowerOf` 0 = 1
x `toPowerOf` n = x * (x `toPowerOf` (n-1))

myAnd :: [Bool] -> Bool
myAnd [] = True
myAnd (x:xs)
  | x = myAnd xs
  | otherwise = False

myAndFoldr :: [Bool] -> Bool
myAndFoldr = foldr (&&) True

myConcat :: [[a]] -> [a]
myConcat [] = []
myConcat (x:xs) = x ++ myConcat xs

myReplicateR :: Int -> a -> [a]
myReplicateR 0 _ = []
myReplicateR n e = e : myReplicateR (n-1) e

nthElem :: [a] -> Int -> a
nthElem (x:xs) 0 = x
nthElem (x:xs) n = nthElem xs (n-1)
nthElem [] _ = undefined

nthElemSafe :: [a] -> Int -> Maybe a
nthElemSafe (x:xs) 0 = Just x
nthElemSafe (x:xs) n = nthElemSafe xs (n-1)
nthElemSafe [] _ = Nothing

myElem :: Eq a => a -> [a] -> Bool
myElem _ [] = False
myElem e (x:xs)
  | e == x = True
  | otherwise = myElem e xs

merge :: Ord a => [a] -> [a] -> [a]
merge [] [] = []
merge [] ys = ys
merge xs [] = xs
merge (x:xs) (y:ys)
  | x < y = x:merge xs (y:ys)
  | x == y = x:y:merge xs ys
  | otherwise = y:merge (x:xs) ys

msort :: Ord a => [a] -> [a]
msort [] = []
msort [x] = [x]
msort xs = merge (msort (take halflen xs)) (msort (drop halflen xs))
  where halflen = length xs `div` 2

-- Other random functions

increasing :: Ord a => [a] -> Bool
increasing [] = False
increasing (x:xs) = inc xs x True
  where inc [] _ bl = True
        inc (_:_) _ False = False
        inc (x:xs) a True = inc xs x (a < x)

-- Could implement the error handling for the empty list case below
-- using Maybe instead of error resulting in a type:
-- mymax :: Ord a => [a] -> Maybe a
mymax :: Ord a => [a] -> a
mymax [] = error "A empty list has no maximum"
mymax (x:xs) = aux xs x
  where aux [] y = y
        aux (x:xs) y
          | x > y = aux xs x
          | otherwise = aux xs y

-- A seemingly nicer implementation of mymax above
mymax2 :: Ord a => [a] -> Maybe a
mymax2 [] = Nothing
mymax2 (x:xs) = Just $ foldr' lrgr x xs
  where lrgr a b
          | a > b = a
          | otherwise = b

flatten :: [[a]] -> [a]
flatten [] = []
flatten (x:xs) = x ++ flatten xs

-- Note: the definition below is the same as: flatten' = foldr (++) []
flatten' :: [[a]] -> [a]
flatten' xss = flat xss []
  where flat [] acc = acc
        flat (y:ys) acc = let nacc = acc ++ y
                          in nacc `seq` flat ys nacc

-- Implementation of the square root function using fixed points *doesn't work*
sqrt' x = fix (\f y -> if ((y * y) - x) / x <= 0.0001 then y else y / x) x

-- Learning from https://en.wikibooks.org/wiki/Haskell/Existentially_quantified_types
data ShowBox = forall s. Show s => SB s

instance Show ShowBox where
  show (SB a) = show a

type HList = [ShowBox]

heterogeniusList :: HList
heterogeniusList = [SB 1, SB ['a'..'c'], SB 'd', SB 3]

-- How do i pattern match on (SB a) when a would be a list of depth n
-- Is it possible to restrict ShowBox to only hold non-list values?
-- flattenHList :: HList -> HList
-- flattenHList [] = []
-- flattenHList (x:xs) = 

-- Questions from the haskell wiki
-- url: http://www.haskell.org/haskellwiki/99_questions/1_to_10

-- 1
myLast :: [a] -> a
myLast lst = lst !! (len - 1)
	where len = length lst

myLast2 :: [a] -> a
myLast2 [] = error "No last element!"
myLast2 (x:[]) = x
myLast2 (x:xs) = myLast2 xs

-- Blank main function (can test things here)
main :: IO ()
main =  undefined