Skip to content
{{ message }}

Instantly share code, notes, and snippets.

# gfixler/gist:11363259

Last active Aug 29, 2015
Learn You A Haskell scratchpad
 import Data.List import Data.Char import qualified Data.Map as Map import qualified Data.Set as Set factorial n = product [1..n] dublist x = x ++ x double x = x + x quadruple x = (double . double) x average ns = sum ns `div` length ns first x = x !! 0 final x = first (reverse x) ultimate x = x !! (length x - 1) nth n x = final (take n x) n = a `div` length xs where a = 10 xs = [1,2,3,4,5] add' :: Int -> (Int -> Int) add' x y = x + y palindrome :: String -> Bool palindrome xs = xs == reverse xs myEven :: Integral a => a -> Bool myEven n = n `mod` 2 == 0 mySplitAt :: Int -> [a] -> ([a],[a]) mySplitAt n xs = (take n xs, drop n xs) myRecip :: Fractional a => a -> a myRecip n = 1/n myAbs :: Int -> Int myAbs n = if n >= 0 then n else - n mySignum :: Int -> Int mySignum n = if n < 0 then -1 else if n == 0 then 0 else 1 myGuardedSignum :: Int -> Int myGuardedSignum n | n < 0 = -1 | n == 0 = 0 | otherwise = 1 myFst :: (a, b) -> a myFst (x,_) = x mySnd :: (a, b) -> b mySnd (_,y) = y test :: [Char] -> Bool test ['a',_,_] = True test _ = False test2 :: [Char] -> Bool test2 ('a':_) = True test2 _ = False myOdds :: Int -> [Int] myOdds n = map f [0..n-1] where f x = x * 2 + 1 myOdds2 :: Int -> [Int] myOdds2 n = map(\x -> x * 2 + 1)[0..n-1] always4711 :: a -> Int always4711 _ = 4711 halve :: Ord a => [a] -> ([a],[a]) halve xs | xs == [] = error "Can't halve an empty list!" | even (length xs) = (take half xs, drop half xs) | otherwise = error "Can't halve an odd-length list!" where half = length xs `div` 2 (|||) :: Bool -> Bool -> Bool True ||| True = True True ||| False = True False ||| True = True False ||| False = False (||||) :: Bool -> Bool -> Bool False |||| False = False _ |||| _ = True safetail :: Eq a => [a] -> [a] safetail x = if x == [] then [] else drop 1 x safetail2 :: [a] -> [a] safetail2 x | null x = [] | otherwise = drop 1 x safetail3 :: [a] -> [a] safetail3 [] = [] safetail3 (a:as) = as factors :: Int -> [Int] factors n = [x | x <- [1..n], n `mod` x == 0] prime :: Int -> Bool prime n = factors n == [1,n] primes :: Int -> [Int] primes n = [x | x <- [2..n], prime x] find' :: Eq a => a -> [(a,b)] -> [b] find' k t = [v | (k',v) <- t, k == k'] pairs' :: [a] -> [(a,a)] pairs' xs = zip xs (tail xs) ordered :: Ord a => [a] -> Bool ordered xs = and [x <= y | (x,y) <- pairs' xs] positions :: Eq a => a -> [a] -> [Int] positions x xs = [i | (x',i) <- zip xs [0..n], x == x'] where n = length xs - 1 isLetter :: Char -> Bool isLetter c | any (== c) ['a'..'z'] = True | otherwise = False let2int :: Char -> Int let2int c = first (positions c ['a'..'z']) int2let :: Int -> Char int2let n = first [c | (c,i) <- zip ['a'..'z'] [0..], n == i] pyths :: Int -> [(Int,Int,Int)] pyths n = [(x,y,z) | x <- [1..n], y <- [1..n], z <- [1..n], x^2 + y^2 == z^2] butlast :: [a] -> [a] butlast xs = reverse (tail (reverse xs)) perfects :: Int -> [Int] perfects n = [x | x <- [1..n], sum (butlast (factors x)) == x] shiftKey :: Int -> (Int,Float,Bool,Float,Float,String,String) -> (Int,Float,Bool,Float,Float,String,String) shiftKey n (f,v,l,ia,oa,itt,ott) = (f+n,v,l,ia,oa,itt,ott) gimme :: Int -> Int -> [Int] gimme 0 x = [] gimme (n+1) x = x : replicate n x -- http://learnyouahaskell.com/syntax-in-functions lucky :: (Integral a) => a -> String lucky 7 = "LUCKY NUMBER SEVEN!" lucky x = "Sorry, you're out of luck, pal!" sayMe :: (Integral a) => a -> String sayMe 1 = "One!" sayMe 2 = "Two!" sayMe 3 = "Three!" sayMe 4 = "Four!" sayMe 5 = "Five!" sayMe x = "Not between 1 and 5" factorial' :: (Integral a) => a -> a factorial' 0 = 1 factorial' n = n * factorial (n - 1) charName :: Char -> String charName 'a' = "Albert" charName 'b' = "Broseph" charName 'c' = "Cecil" addVectors :: (Num a) => (a, a) -> (a, a) -> (a, a) addVectors a b = (fst a + fst b, snd a + snd b) addVectors' :: (Num a) => (a, a) -> (a, a) -> (a, a) addVectors' (x1, y1) (x2, y2) = (x1 + x2, y1 + y2) first' :: (a, b, c) -> a first' (x, _, _) = x second' :: (a, b, c) -> b second' (_, y, _) = y third' :: (a, b, c) -> c third' (_, _, z) = z head' :: [a] -> a head' [] = error "Can't call head on an empty list, dummy!" head' (x:_) = x tell :: (Show a) => [a] -> String tell [] = "The list is empty" tell (x:[]) = "The list has one element: " ++ show x tell (x:y:[]) = "The list has two elements: " ++ show x ++ " and " ++ show y tell (x:y:_) = "This list is long. The first two elements are: " ++ show x ++ " and " ++ show y length' :: (Num b) => [a] -> b length' [] = 0 length' (_:xs) = 1 + length' xs sum' :: (Num a) => [a] -> a sum' [] = 0 sum' (x:xs) = x + sum' xs capital :: String -> String capital "" = "Empty string!" capital all@(x:_) = "The first letter of " ++ all ++ " is " ++ [x] bmiTell :: (RealFloat a) => a -> String bmiTell bmi | bmi <= 18.5 = "You're underewight, you emo you!" | bmi <= 25.0 = "You're supposedly normal. Pffft, I bet you're ugly!" | bmi <= 30.0 = "You're fat! Lose some weight, fatty!" | otherwise = "You're a whale, congratulations!" bmiTell' :: (RealFloat a) => a -> a -> String bmiTell' weight height | weight / height ^ 2 <= 18.5 = "You're underewight, you emo you!" | weight / height ^ 2 <= 18.5 = "You're supposedly normal. Pffft, I bet you're ugly!" | weight / height ^ 2 <= 18.5 = "You're fat! Lose some weight, fatty!" | otherwise = "You're a whale, congratulations!" max' :: (Ord a) => a -> a -> a max' a b | a > b = a | otherwise = b myCompare :: (Ord a) => a -> a -> Ordering a `myCompare` b | a < b = LT | a == b = EQ | otherwise = GT bmiTell'' :: (RealFloat a) => a -> a -> String bmiTell'' weight height | bmi <= 18.5 = "You're underewight, you emo you!" | bmi <= 25.0 = "You're supposedly normal. Pffft, I bet you're ugly!" | bmi <= 30.0 = "You're fat! Lose some weight, fatty!" | otherwise = "You're a whale, congratulations!" where bmi = weight / height ^ 2 bmiTell''' :: (RealFloat a) => a -> a -> String bmiTell''' weight height | bmi <= skinny = "You're underewight, you emo you!" | bmi <= normal = "You're supposedly normal. Pffft, I bet you're ugly!" | bmi <= fat = "You're fat! Lose some weight, fatty!" | otherwise = "You're a whale, congratulations!" where bmi = weight / height ^ 2 skinny = 18.5 normal = 25.0 fat = 30.0 bmiTell'''' :: (RealFloat a) => a -> a -> String bmiTell'''' weight height | bmi <= skinny = "You're underewight, you emo you!" | bmi <= normal = "You're supposedly normal. Pffft, I bet you're ugly!" | bmi <= fat = "You're fat! Lose some weight, fatty!" | otherwise = "You're a whale, congratulations!" where bmi = weight / height ^ 2 (skinny, normal, fat) = (18.5, 25.0, 30.0) initials :: String -> String -> String initials (a:_) (b:_) = "Your initials are " ++ [a] ++ "." ++ [b] ++ "." initials' :: String -> String -> String initials' firstname lastname = [f] ++ ". " ++ [l] ++ "." where (f:_) = firstname (l:_) = lastname calcBmis :: (RealFloat a) => [(a, a)] -> [a] calcBmis xs = [bmi w h | (w, h) <- xs] where bmi weight height = weight / height ^ 2 cylinder :: (RealFloat a) => a -> a -> a cylinder r h = let sideArea = 2 * pi * r * h topArea = pi * r ^ 2 in sideArea + 2 * topArea calcBmis' :: (RealFloat a) => [(a, a)] -> [a] calcBmis' xs = [bmi | (w, h) <- xs, let bmi = w / h ^ 2] calcFatBmis :: (RealFloat a) => [(a, a)] -> [a] calcFatBmis xs = [bmi | (w, h) <- xs, let bmi = w / h ^ 2, bmi >= 25.0] headcase :: [a] -> a headcase xs = case xs of [] -> error "No head for empty lists!" (x:_) -> x describeList :: [a] -> String describeList xs = "The list is " ++ case xs of [] -> "empty." [x] -> "a singleton list." xs -> "a longer list." describeList' :: [a] -> String describeList' xs = "The list is " ++ what xs where what [] = "empty." what [x] = "a singleton list." what xs = "a longer list." -- http://learnyouahaskell.com/recursion maximum' :: (Ord a) => [a] -> a maximum' [] = error "maximum of empty list" maximum' [x] = x maximum' (x:xs) | x > maxTail = x | otherwise = maxTail where maxTail = maximum' xs maximum'' :: (Ord a) => [a] -> a maximum'' [] = error "maximum of empty list" maximum'' [x] = x maximum'' (x:xs) = max x (maximum' xs) replicate' :: (Num i, Ord i) => i -> a -> [a] replicate' n x | n <= 0 = [] | otherwise = x:replicate' (n-1) x take' :: (Num i, Ord i) => i -> [a] -> [a] take' n _ | n <= 0 = [] take' _ [] = [] take' n (x:xs) = x : take' (n-1) xs -- this one is mine; just testing things out surround :: (Num i, Ord i) => i -> String -> String surround n s | n <= 0 = s | otherwise = "(" ++ (surround (n-1) s) ++ ")" reverse' :: [a] -> [a] reverse' [] = [] reverse' (x:xs) = reverse' xs ++ [x] repeat' :: a -> [a] repeat' x = x:repeat' x zip' :: [a] -> [b] -> [(a,b)] zip' _ [] = [] zip' [] _ = [] zip' (x:xs) (y:ys) = (x,y):zip' xs ys elem' :: (Eq a) => a -> [a] -> Bool elem' a [] = False elem' a (x:xs) | a == x = True | otherwise = a `elem'` xs quicksort :: (Ord a) => [a] -> [a] quicksort [] = [] quicksort (x:xs) = let smallerSorted = quicksort [a | a <- xs, a <= x] biggerSorted = quicksort [a | a <- xs, a > x] in smallerSorted ++ [x] ++ biggerSorted -- http://learnyouahaskell.com/higher-order-functions multThree :: (Num a) => a -> a -> a -> a multThree x y z = x * y * z compareWithHundred :: (Num a, Ord a) => a -> Ordering compareWithHundred x = compare 100 x divideByTen :: (Floating a) => a -> a divideByTen = (/10) isUpperAlphanum :: Char -> Bool isUpperAlphanum = (`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 = g where g x y = f y x flip'' :: (a -> b -> c) -> b -> a -> c flip'' f y x = f x y map' :: (a -> b) -> [a] -> [b] map' _ [] = [] map' f (x:xs) = f x : map f xs filter' :: (a -> Bool) -> [a] -> [a] filter' _ [] = [] filter' p (x:xs) | p x = x : filter' p xs | otherwise = filter' p xs quicksort' :: (Ord a) => [a] -> [a] quicksort' [] = [] quicksort' (x:xs) = let smallerSorted = quicksort' (filter (<=x) xs) biggerSorted = quicksort' (filter (>x) xs) in smallerSorted ++ [x] ++ biggerSorted largestDivisible :: (Integral a) => a largestDivisible = head (filter p [100000,99999..]) where p x = x `mod` 3829 == 0 chain :: (Integral a) => a -> [a] chain 1 =  chain n | even n = n:chain (n `div` 2) | odd n = n:chain (n*3 + 1) numLongChains :: Int numLongChains = length (filter isLong (map chain [1..100])) where isLong xs = length xs > 15 numLongChains' :: Int numLongChains' = length (filter (\xs -> length xs > 15) (map chain [1..100])) addThree :: (Num a) => a -> a -> a -> a addThree x y z = x + y + z addThree' :: (Num a) => a -> a -> a -> a addThree' = \x -> \y -> \z -> x + y + z flip''' :: (a -> b -> c) -> b -> a -> c flip''' f = \x y -> f y x sum'' :: (Num a) => [a] -> a sum'' xs = foldl (\acc x -> acc + x) 0 xs sum''' :: (Num a) => [a] -> a sum''' = foldl (+) 0 elem'' :: (Eq a) => a -> [a] -> Bool elem'' y ys = foldl (\acc x -> if x == y then True else acc) False ys map'' :: (a -> b) -> [a] -> [b] map'' f xs = foldr (\x acc -> f x : acc) [] xs foldMaximum :: (Ord a) => [a] -> a foldMaximum = foldr1 (\x acc -> if x > acc then x else acc) foldReverse :: [a] -> [a] foldReverse = foldl (\acc x -> x : acc) [] foldProduct :: (Num a) => [a] -> a foldProduct = foldr1 (*) foldFilter :: (a -> Bool) -> [a] -> [a] foldFilter p = foldr (\x acc -> if p x then x : acc else acc) [] foldHead :: [a] -> a foldHead = foldr1 (\x _ -> x) foldLast :: [a] -> a foldLast = foldl1 (\_ x -> x) sqrtSums :: Int sqrtSums = length (takeWhile (<1000) (scanl1 (+) (map sqrt [1..]))) + 1 oddSquareSum :: Integer oddSquareSum = sum (takeWhile (<10000) (filter odd (map (^2) [1..]))) oddSquareSum' :: Integer oddSquareSum' = sum . takeWhile (<10000) . filter odd . map (^2) \$ [1..] oddSquareSum''' :: Integer oddSquareSum''' = let oddSquares = filter odd \$ map (^2) [1..] belowLimit = takeWhile (<10000) oddSquares in sum belowLimit -- http://learnyouahaskell.com/modules search :: (Eq a) => [a] -> [a] -> Bool search needle haystack = let nlen = length needle in foldl (\acc x -> if take nlen x == needle then True else acc) False (tails haystack) encode :: Int -> String -> String encode shift msg = let ords = map ord msg shifted = map (+ shift) ords in map chr shifted encode' :: Int -> String -> String encode' shift = map (chr . (+ shift) . ord) phoneBook = [("betty","555-2938") ,("bonnie","452-2928") ,("patsy","493-2928") ,("lucille","205-2928") ,("wendy","939-8282") ,("penny","853-2492") ] findKey :: (Eq k) => k -> [(k,v)] -> v findKey key xs = snd . head . filter (\(k,v) -> key == k) \$ xs findKey' :: (Eq k) => k -> [(k,v)] -> Maybe v findKey' key [] = Nothing findKey' key ((k,v):xs) = if key == k then Just v else findKey' key xs findKey'' :: (Eq k) => k -> [(k,v)] -> Maybe v findKey'' key = foldr (\(k,v) acc -> if key == k then Just v else acc) Nothing fromList' :: (Ord k) => [(k,v)] -> Map.Map k v fromList' = foldr (\(k,v) acc -> Map.insert k v acc) Map.empty phoneBook2 = [("betty","555-2938") ,("betty","342-2492") ,("bonnie","452-2928") ,("patsy","493-2928") ,("patsy","943-2929") ,("patsy","827-9162") ,("lucille","205-2928") ,("wendy","939-8282") ,("penny","853-2492") ,("penny","555-2111") ] phoneBookToMap :: (Ord k) => [(k, String)] -> Map.Map k String phoneBookToMap xs = Map.fromListWith (\number1 number2 -> number1 ++ ", " ++ number2) xs phoneBookToMap' :: (Ord k) => [(k, a)] -> Map.Map k [a] phoneBookToMap' xs = Map.fromListWith (++) \$ map (\(k,v) -> (k,[v])) xs -- http://learnyouahaskell.com/making-our-own-types-and-typeclasses data Shape' = Circle' Float Float Float | Rectangle' Float Float Float Float deriving (Show) surface' :: Shape' -> Float surface' (Circle' _ _ r) = pi * r ^ 2 surface' (Rectangle' x1 y1 x2 y2) = (abs \$ x2 - x1) * (abs \$ y2 -y1) data Point = Point Float Float deriving (Show) data Shape = Circle Point Float | Rectangle Point Point deriving (Show) surface :: Shape -> Float surface (Circle _ r) = pi * r ^ 2 surface (Rectangle (Point x1 y1) (Point x2 y2)) = (abs \$ x2 - x1) * (abs \$ y2 - y1) nudge :: Shape -> Float -> Float -> Shape nudge (Circle (Point x y) r) a b = Circle (Point (x+a) (y+b)) r nudge (Rectangle (Point x1 y1) (Point x2 y2)) a b = Rectangle (Point (x1+a) (y1+b)) (Point (x2+a) (y2+b)) baseCircle :: Float -> Shape baseCircle r = Circle (Point 0 0) r baseRect :: Float -> Float -> Shape baseRect w h = Rectangle (Point 0 0) (Point w h) data Person' = Person' String String Int Float String String deriving (Show) firstName' :: Person' -> String firstName' (Person' firstname _ _ _ _ _) = firstname lastName' :: Person' -> String lastName' (Person' _ lastname _ _ _ _) = lastname age' :: Person' -> Int age' (Person' _ _ age _ _ _) = age height' :: Person' -> Float height' (Person' _ _ _ height _ _) = height phoneNumber' :: Person' -> String phoneNumber' (Person' _ _ _ _ number _) = number flavor' :: Person' -> String flavor' (Person' _ _ _ _ _ flavor) = flavor data Person = Person { firstName :: String , lastName :: String , age :: Int , height :: Float , phoneNumber :: String , flavor :: String } deriving (Show) data Vector a = Vector a a a deriving (Show) vplus :: (Num t) => Vector t -> Vector t -> Vector t (Vector i j k) `vplus` (Vector l m n) = Vector (i+l) (j+m) (k+n) vectMult :: (Num t) => Vector t -> t -> Vector t (Vector i j k) `vectMult` m = Vector (i*m) (j*m) (k*m) scalarMult :: (Num t) => Vector t -> Vector t -> t (Vector i j k) `scalarMult` (Vector l m n) = i*l + j*m + k*n data ComparablePerson = ComparablePerson { cp_firstName :: String , cp_lastName :: String , cp_age :: Int } deriving (Eq, Show, Read) data Day = Monday | Tuesday | Wednesday | Thursday | Friday | Saturday | Sunday deriving (Eq, Ord, Show, Read, Bounded, Enum) data LockerState = Taken | Free deriving (Show, Eq) type Code = String type LockerMap = Map.Map Int (LockerState, Code) lockerLookup :: Int -> LockerMap -> Either String Code lockerLookup lockerNumber map = case Map.lookup lockerNumber map of Nothing -> Left \$ "Locker number " ++ show lockerNumber ++ " doesn't exist!" Just (state, code) -> if state /= Taken then Right code else Left \$ "Locker " ++ show lockerNumber ++ " is already taken!" lockers :: LockerMap lockers = Map.fromList [(100,(Taken,"ZD39I")) ,(101,(Free,"JAH3I")) ,(103,(Free,"IQSA9")) ,(105,(Free,"QOTSA")) ,(109,(Taken,"893JJ")) ,(110,(Taken,"99292")) ] data List' a = Empty' | Cons a (List' a) deriving (Show, Read, Eq, Ord) infixr 5 :-: data List a = Empty | a :-: (List a) deriving (Show, Read, Eq, Ord) infixr 5 .++ (.++) :: List a -> List a -> List a Empty .++ ys = ys (x :-: xs) .++ ys = x :-: (xs .++ ys) data Tree a = EmptyTree | Node a (Tree a) (Tree a) deriving (Show, Read, Eq) singleton :: a -> Tree a singleton x = Node x EmptyTree EmptyTree treeInsert :: (Ord a) => a -> Tree a -> Tree a treeInsert x EmptyTree = singleton x treeInsert x (Node a left right) | x == a = Node x left right | x < a = Node a (treeInsert x left) right | x > a = Node a left (treeInsert x right) treeElem :: (Ord a) => a -> Tree a -> Bool treeElem x EmptyTree = False treeElem x (Node a left right) | x == a = True | x < a = treeElem x left | x > a = treeElem x right data TrafficLight = Red | Yellow | Green instance Eq TrafficLight where Red == Red = True Green == Green = True Yellow == Yellow = True _ == _ = False instance Show TrafficLight where show Red = "Red Light" show Yellow = "Yellow Light" show Green = "Green Light" 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 instance YesNo (Maybe a) where yesno (Just _) = True yesno Nothing = False instance YesNo (Tree a) where yesno EmptyTree = False yesno _ = True instance YesNo TrafficLight where yesno Red = False yesno _ = True yesnoIf :: (YesNo y) => y -> a -> a -> a yesnoIf yesnoVal yesResult noResult = if yesno yesnoVal then yesResult else noResult
to join this conversation on GitHub. Already have an account? Sign in to comment