Haskell snippets

BST.hs

module BST where

import           Data.List

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

unitTree :: a -> Tree a
unitTree x = Node x EmptyTree EmptyTree

treeAdd :: (Ord a) => a -> Tree a -> Tree a
treeAdd i EmptyTree = unitTree i
treeAdd i (Node a lhs rhs) | -- destructuring param-ed tree
                             i == a = Node a lhs rhs
                           | i < a  = Node a (treeAdd i lhs) rhs
                           | i > a  = Node a lhs (treeAdd i rhs)

treeExist :: (Ord a) => a -> Tree a -> Bool
treeExist i EmptyTree = False
treeExist i (Node a lhs rhs) | i == a = True
                             | i < a  = treeExist i lhs
                             | i > a  = treeExist i rhs

treeMake :: (Ord a) => [a] -> Tree a
treeMake [] = EmptyTree
treeMake n  = foldr treeAdd EmptyTree n

instance Functor Tree where
  fmap f EmptyTree = EmptyTree
  fmap f (Node a lhs rhs) = Node (f a) (fmap f lhs) (fmap f rhs)

codewars.hs

-- high and low
module Kata (highAndLow) where

createIntList :: String -> [Integer]
createIntList input = map (\x -> read x :: Integer) (words input)

highAndLow :: String -> String
highAndLow input = show (maximum . createIntList $ input) ++ " " ++ show (minimum . createIntList $ input)

-- test
import Test.Hspec
import Kata (highAndLow)

main :: IO ()
main = hspec $
  describe "Example Tests" $ do
    it "4 5 29 54 4 0 -214 542 -64 1 -3 6 -6" $ 
      highAndLow "4 5 29 54 4 0 -214 542 -64 1 -3 6 -6" `shouldBe`  "542 -214"

hof.hs

module Main where

main :: IO ()
main = do
  putStrLn (greet "hello world")
  putStrLn (greet "viet")


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

map' :: [a] -> (a -> b) -> [b]
map' [] f = []
map' (x:xs) f = f x : map' xs f

ft :: [a] -> (a -> Bool) -> [a]
ft [] f = []
ft (x:xs) f
  | f x = x : ft xs f
  | otherwise = ft xs f

quicksort :: (Ord a) => [a] -> [a]
quicksort [] = []
quicksort (x:xs) = lhs ++ [x] ++ rhs
  where lhs = qs (ft xs (<= x))
        rhs = qs (ft xs (> x))

monads.hs

repl :: Int -> a -> [a]
repl 0 _ = []
repl n x = x : repl (n-1) x

myRepM :: (Monad m) => Int -> m a -> m [a]
myRepM 0 _ = return []
myRepM n mx = mx >>= (\x -> myRepM (n-1) mx)

myMapM :: (Monad m) => (a -> m b) -> [a] -> m [b]
myMapM f [] = return []
myMapM f (x:xs) = f x >>= (\y -> myMapM f xs >>= (\ys -> return $ y:ys))

myMapM2 :: (Monad m) => (a -> m b) -> [a] -> m [b]
myMapM2 f [] = return []
myMapM2 f (x:xs) = do
  y <- f x
  ys <- myMapM2 f xs
  return $ y:ys

mySeq :: (Monad m) => [m a] -> m [a]
mySeq [] = return []
mySeq (mx:mxs) = mx
                  >>= (\x -> mySeq mxs
                        >>= (\xs -> return $ x:xs))

mySeq2 :: (Monad m) => [m a] -> m [a]
mySeq2 [] = return []
mySeq2 (mx:mxs) = do
  x <- mx
  xs <- mySeq2 mxs
  return $ x:xs

recursion.hs

module Main where

main :: IO ()
main = do
  putStrLn (greet "hello world")
  putStrLn (greet "viet")


fac :: (Integral a) => a -> a
fac 0 = 1
fac n = n * fac (n-1)

dotVec2 :: (Num a) => (a, a) -> (a, a) -> a
dotVec2 (ax, ay) (bx, by) = ax * bx + ay * by

head' :: [a] -> a
head' [] = error "Require > 1 args"
head' (x:_) = x

dotVec :: (Num a) => [a] -> [a] -> a
dotVec [x] [y] = x*y
dotVec (x:xs) (y:ys) = x*y + (dotVec xs ys)

switch :: (Eq a, Num a) => a -> String
switch x
  | x == 1 = "one"
  | x == 2 = "two"
  | otherwise = "large"

-- find max
max' :: (Ord a) => [a] -> a
max' [] = error "no empty list"
max' [x] = x
max' (x:xs)
  | x > maxRest = x
  | otherwise = maxRest
  where maxRest = max' xs

-- replicate
repl' :: (Ord n, Num n) => n -> a -> [a]
repl' n a
  | n <= 0 = []
  | otherwise = a:repl' (n-1) a

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

-- quick sort
qsort :: (Ord a) => [a] -> [a]
qsort [] = []
qsort (x:xs) =
  let lhs = qsort [ a | a <- xs, a <= x ]
      rhs = qsort [ a | a <- xs, a >  x ]
   in lhs ++ [x] ++ rhs

qs :: (Ord a) => [a] -> [a]
qs [] = []
qs (x:xs) = qs lhs ++ [x] ++ qs rhs
  where lhs = [ a | a <- xs, a <= x ]
        rhs = [ a | a <- xs, a >  x ]

-- palindrome list
check :: (Ord a) => [a] -> Bool
check [] = True
check (x:[]) = True
check (x:xs)
  | x /= last xs = False
  | otherwise = check (init xs)

-- permutation
remove :: Int -> [a] -> [a]
remove i [] = []
remove i (x:[]) = []
remove i x
  | i >= length x = error "nope"
  | otherwise = lhs ++ rhs
    where (lhs, a:rhs) = splitAt i x

p :: [x] -> [[x]]
p [] = []
p (x:[]) = [[x]]
p x = [ [x!!i] ++ prest | i <- [0..y], prest <- p (remove i x)]
  where y = length x - 1