Skip to content
Browse files

Initial import

  • Loading branch information...
0 parents commit 6d5df9ff2e0ba7e1699fdc79caa943ef9937d2e5 @igstan committed May 21, 2010
Showing with 905 additions and 0 deletions.
  1. +1 −0 README
  2. +55 −0 caesar.hs
  3. +194 −0 functional-parsers.hs
  4. +81 −0 game-of-life.hs
  5. +98 −0 higher-order-functions.hs
  6. +282 −0 interactive-programs.hs
  7. +63 −0 recursive-functions.hs
  8. BIN solutions.pdf
  9. +108 −0 spikes.hs
  10. +23 −0 test.hs
1 README
@@ -0,0 +1 @@
+Code developed while reading "Programming in Haskell", by Graham Hutton.
55 caesar.hs
@@ -0,0 +1,55 @@
+import Char (ord, chr, isLower, isUpper, isAlpha, toLower)
+
+let2int :: Char -> Char -> Int
+let2int c firstLetter = ord c - ord firstLetter
+
+int2let :: Int -> Char -> Char
+int2let n firstLetter = chr (ord firstLetter + n)
+
+shift :: Int -> Char -> Char
+shift n char | isLower char = int2let (((let2int char 'a') + n) `mod` 26) 'a'
+ | isUpper char = int2let (((let2int char 'A') + n) `mod` 26) 'A'
+ | otherwise = char
+
+encode :: Int -> String -> String
+encode factor xs = [shift factor x | x <- xs]
+
+letters :: String -> Int
+letters xs = length [x | x <- xs, isAlpha x]
+
+count :: Char -> String -> Int
+count char inString = length [c | c <- inString, toLower c == char]
+
+letterFreqs :: [Float]
+letterFreqs = [8.2, 1.5, 2.8, 4.3, 12.7, 2.2, 2.0, 6.1, 7.0, 0.2, 0.8, 4.0, 2.4,
+ 6.7, 7.5, 1.9, 0.1, 6.0, 6.3, 9.1, 2.8, 1.0, 2.4, 0.2, 2.0, 0.1]
+
+percent :: Int -> Int -> Float
+percent n m = (fromIntegral n / fromIntegral m) * 100
+
+freqs :: String -> [Float]
+freqs xs = [percent (count x xs) n | x <- ['a'..'z']]
+ where n = letters xs
+
+chiSquare :: [Float] -> [Float] -> Float
+chiSquare observedFreqs expectedFreqs = sum [(o - e)^2 / e | (o,e) <- zip observedFreqs expectedFreqs]
+
+rotate :: Int -> [a] -> [a]
+rotate n xs = drop n xs ++ take n xs
+
+positions :: Eq a => a -> [a] -> [Int]
+positions x xs = [i | (x', i) <- zip xs [0..n], x == x']
+ where n = length xs - 1
+
+find :: Eq a => a -> [(a, b)] -> [b]
+find key pairs = [pair | (k, pair) <- pairs, k == key]
+
+positions' :: Eq a => a -> [a] -> [Int]
+positions' x xs = find x (zip xs [0..n])
+ where n = length xs - 1
+
+crack :: String -> String
+crack xs = encode (-factor) xs
+ where factor = (positions (minimum chiTable) chiTable) !! 0
+ chiTable = [chiSquare (rotate n table') letterFreqs | n <- [0..25]]
+ table' = freqs xs
194 functional-parsers.hs
@@ -0,0 +1,194 @@
+import Data.Char (isDigit, isLower, isUpper, isAlpha, isAlphaNum, isSpace)
+
+type Parser a = String -> [(a, String)]
+
+return' :: a -> Parser a
+return' v = \input -> [(v, input)]
+
+failure :: Parser a
+failure = \input -> []
+
+item :: Parser Char
+item = \input -> case input of
+ [] -> []
+ (x:xs) -> [(x, xs)]
+
+parse :: Parser a -> String -> [(a, String)]
+parse parser input = parser input
+
+-- Sequencing operator
+(>>>=) :: Parser a -> (a -> Parser b) -> Parser b
+p >>>= f = \input -> case parse p input of
+ [] -> []
+ [(v, out)] -> parse (f v) out
+
+-- p :: Parser (Char, Char)
+-- p = do x <- item
+-- item
+-- y <- item
+-- return' (x, y)
+
+p :: Parser (Char, Char)
+p = item >>>= \x ->
+ item >>>= \_ ->
+ item >>>= \y ->
+ return' (x, y)
+
+(+++) :: Parser a -> Parser a -> Parser a
+p +++ q = \input -> case parse p input of
+ [] -> parse q input
+ [(v, out)] -> [(v, out)]
+
+satisfies :: (Char -> Bool) -> Parser Char
+satisfies predicate = item >>>= \x -> if predicate x then return' x else failure
+
+digit :: Parser Char
+digit = satisfies isDigit
+
+lower :: Parser Char
+lower = satisfies isLower
+
+upper :: Parser Char
+upper = satisfies isUpper
+
+letter :: Parser Char
+letter = satisfies isAlpha
+
+alphanum :: Parser Char
+alphanum = satisfies isAlphaNum
+
+char :: Char -> Parser Char
+char x = satisfies (== x)
+
+string :: String -> Parser String
+string [] = return' []
+string (x:xs) = char x >>>= \_ ->
+ string xs >>>= \_ ->
+ return' (x:xs)
+
+ident :: Parser String
+ident = lower >>>= \x ->
+ many alphanum >>>= \xs ->
+ return' (x:xs)
+
+nat :: Parser Int
+nat = many1 digit >>>= \xs ->
+ return' (read xs)
+
+space :: Parser ()
+space = many (satisfies isSpace) >>>= \_ ->
+ return' ()
+
+token :: Parser a -> Parser a
+token p = space >>>= \_ ->
+ p >>>= \v ->
+ space >>>= \_ ->
+ return' v
+
+identifier :: Parser String
+identifier = token ident
+
+natural :: Parser Int
+natural = token nat
+
+symbol :: String -> Parser String
+symbol xs = token (string xs)
+
+list :: Parser [Int]
+list = symbol "[" >>>= \_ ->
+ natural >>>= \n ->
+ many (symbol "," >>>= \_ -> natural) >>>= \ns ->
+ symbol "]" >>>= \_ ->
+ return' (n:ns)
+
+-- Arithmetic BNF grammar
+-- expr ::= expr + expr | expr * expr | (expr) | nat
+-- nar ::= 0 | 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9
+
+-- expr ::= term ( + expr | - expr | '')
+-- term ::= factor (* term | / term | '')
+-- factor ::= (expr) | nat
+-- nat ::= 0 | 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9
+
+-- expr ::= term ( + expr | - expr | '')
+-- term ::= expo (* term | / term | '')
+-- factor ::= atom (^ factor | '')
+-- atom ::= (expr) | nat
+-- nat ::= 0 | 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9
+
+expr :: Parser Int
+expr = term >>>= \t ->
+ ((symbol "+" >>>= \_ ->
+ expr >>>= \e ->
+ return' (t + e))
+ +++
+ (symbol "-" >>>= \_ ->
+ expr >>>= \e ->
+ return' (t + e)))
+ +++ return' t
+
+term :: Parser Int
+term = factor >>>= \f ->
+ ((symbol "*" >>>= \_ ->
+ term >>>= \t ->
+ return' (f * t))
+ +++
+ (symbol "/" >>>= \_ ->
+ term >>>= \t ->
+ return' (f `div` t)))
+ +++ return' f
+
+factor :: Parser Int
+factor = atom >>>= \a ->
+ (symbol "^" >>>= \_ ->
+ factor >>>= \f ->
+ return' (a ^ f))
+ +++ return' a
+
+atom :: Parser Int
+atom = (symbol "(" >>>= \_ ->
+ expr >>>= \e ->
+ symbol ")" >>>= \_ ->
+ return' e)
+ +++ natural
+
+eval :: String -> Int
+eval xs = case parse expr xs of
+ [(n, [])] -> n
+ [(_, out)] -> error ("unused input " ++ out)
+ [] -> error "invalid input"
+
+int :: Parser Int
+int = (symbol "-" >>>= \_ ->
+ nat >>>= \n ->
+ return' (-n))
+ +++ nat
+
+comment :: Parser ()
+comment = symbol "--" >>>= \_ ->
+ many (satisfies (/= '\n')) >>>= \_ ->
+ char '\n' >>>= \_ ->
+ return' ()
+
+-- expr ::= expr - nat | nat
+-- nat ::= 0 | 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9
+
+nexpr :: Parser Int
+nexpr = (nexpr >>>= \e ->
+ symbol "-" >>>= \_ ->
+ natural >>>= \n ->
+ return' (e - n))
+ +++ natural
+
+many :: Parser a -> Parser [a]
+many p = many1 p +++ return' []
+
+many1 :: Parser a -> Parser [a]
+many1 p = p >>>= \v ->
+ many p >>>= \vs ->
+ return' (v:vs)
+
+nexpr' :: Parser Int
+nexpr' = natural >>>= \n ->
+ many (symbol "-" >>>= \_ -> natural) >>>= \ns ->
+ return' (foldl (-) n ns)
81 game-of-life.hs
@@ -0,0 +1,81 @@
+-- Game of Life
+
+width :: Int
+width = 5
+
+height :: Int
+height = 5
+
+type Pos = (Int, Int)
+
+type Board = [Pos]
+
+glider :: Board
+glider = [(4,2), (2,3), (4,3), (3,4), (4,4)]
+
+goto :: Pos -> IO ()
+goto (x,y) = putStr ("\ESC[" ++ show y ++ ";" ++ show x ++ "H")
+
+writeAt :: Pos -> String -> IO ()
+writeAt pos xs = do goto pos
+ putStr xs
+
+seqn :: [IO a] -> IO ()
+seqn [] = return ()
+seqn (a:as) = do a
+ seqn as
+
+showCells :: Board -> IO ()
+showCells b = seqn [writeAt p "O" | p <- b]
+
+isAlive :: Board -> Pos -> Bool
+isAlive b p = elem p b
+
+isEmpty :: Board -> Pos -> Bool
+isEmpty board position = not (isAlive board position)
+
+neighbs :: Pos -> [Pos]
+neighbs (x,y) = map wrap [(x-1,y-1), (x,y-1),
+ (x+1,y-1), (x-1,y),
+ (x+1,y), (x-1,y+1),
+ (x,y+1), (x+1,y+1)]
+
+wrap :: Pos -> Pos
+wrap (x,y) = (((x-1) `mod` width) + 1,
+ ((y-1) `mod` height) + 1)
+
+liveNeighbs :: Board -> Pos -> Int
+liveNeighbs board = length . filter (isAlive board) . neighbs
+
+survivors :: Board -> [Pos]
+survivors board = [p | p <- board, elem (liveNeighbs board p) [2,3]]
+
+-- births :: Board -> [Pos]
+-- births board = [(x,y) | x <- [1..width],
+-- y <- [1..height],
+-- isEmpty board (x,y),
+-- liveNeighbs board(x,y) == 3]
+
+births :: Board -> [Pos]
+births board = [p | p <- rmdups (concat (map neighbs board)),
+ isEmpty board p,
+ liveNeighbs board p == 3]
+
+rmdups :: Eq a => [a] -> [a]
+rmdups [] = []
+rmdups (x:xs) = x : rmdups (filter (/= x) xs)
+
+nextgen :: Board -> Board
+nextgen board = survivors board ++ births board
+
+clearScreen :: IO ()
+clearScreen = putStr "\ESC[2J"
+
+life :: Board -> IO ()
+life board = do clearScreen
+ showCells board
+ wait 500000
+ life (nextgen board)
+
+wait :: Int -> IO ()
+wait n = seqn [return () | _ <- [1..n]]
98 higher-order-functions.hs
@@ -0,0 +1,98 @@
+import Data.Char (chr, ord)
+
+squaresOfEvens :: Integral a => [a] -> [a]
+squaresOfEvens = map (^ 2) . filter even
+
+-- all even [2,4,6,8]
+-- True
+all' :: (a -> Bool) -> [a] -> Bool
+all' f = and . map f
+
+-- any odd [2,4,6,8]
+-- False
+any' :: (a -> Bool) -> [a] -> Bool
+any' f = or . map f
+
+takeWhile' :: (a -> Bool) -> [a] -> [a]
+takeWhile' _ [] = []
+takeWhile' f (x:xs) | f x = x : takeWhile' f xs
+ | otherwise = []
+
+dropWhile' :: (a -> Bool) -> [a] -> [a]
+dropWhile' _ [] = []
+dropWhile' f (x:xs) | f x = dropWhile' f xs
+ | otherwise = x:xs
+
+map' :: (a -> b) -> [a] -> [b]
+map' f = foldr (\ x ys -> f x : ys) []
+
+filter' :: (a -> Bool) -> [a] -> [a]
+filter' f = foldr (\ x ys -> if f x then x:ys else ys) []
+
+-- dec2int [2,3,4,5]
+-- 2345
+-- 2*1000 + 3*100 + 4*10 + 5*1
+-- (2*100 + 3*10 + 4*1)*10 + 5*1
+-- ((2*10 + 3)*10 + 4)*10 + 5
+dec2int :: [Int] -> Int
+dec2int = foldl (\a b -> a * 10 + b) 0
+
+compose :: [(a -> a)] -> (a -> a)
+compose = foldr (.) id
+
+curry' :: ((a, b) -> c) -> (a -> b -> c)
+curry' f = \a b -> f (a, b)
+
+uncurry' :: (a -> b -> c) -> ((a, b) -> c)
+uncurry' f = \(a, b) -> f a b
+
+unfold :: (t -> Bool) -> (t -> a) -> (t -> t) -> t -> [a]
+unfold p h t x | p x = []
+ | otherwise = h x : unfold p h t (t x)
+
+int2bin :: Int -> [Int]
+int2bin = unfold (== 0) (`mod` 2) (`div` 2)
+
+type Bit = Int
+
+bin2int :: [Bit] -> Int
+-- bin2int bits = sum [w * b | (w, b) <- zip weights bits]
+-- where weights = iterate (*2) 1
+-- bin2int bits = sum $ zipWith (*) weights bits
+-- where weights = iterate (*2) 1
+bin2int = foldr (\x y -> x + 2 * y) 0
+
+make8 :: [Bit] -> [Bit]
+make8 bits = take 8 (bits ++ repeat 0)
+
+make9 :: [Bit] -> [Bit]
+make9 bits = bits' ++ [parity]
+ where bits' = make8 bits
+ parity = if even (sum bits') then 0 else 1
+
+chop8 :: [Bit] -> [[Bit]]
+chop8 [] = []
+chop8 bits = first8 : chop8 (drop 9 bits)
+ where parity = take 1 (drop 8 bits)
+ first8 = if parity == [0] && even (sum (take 8 bits)) then
+ take 8 bits
+ else
+ error "Parity check failed"
+
+chop8' :: [Bit] -> [[Bit]]
+chop8' = unfold null (take 8) (drop 8)
+
+map'' :: (a -> b) -> [a] -> [b]
+map'' f = unfold null (f . head) tail
+
+iterate' :: (a -> a) -> a -> [a]
+iterate' f = unfold (const False) id f
+
+encode :: String -> [Bit]
+encode = concat . map (make9 . int2bin . ord)
+
+decode :: [Bit] -> String
+decode = map (chr . bin2int) . chop8
+
+transmit :: String -> String
+transmit = decode . id . encode
282 interactive-programs.hs
@@ -0,0 +1,282 @@
+import Data.Char (isDigit, isLower, isUpper, isAlpha, isAlphaNum, isSpace)
+
+type Parser a = String -> [(a, String)]
+
+return' :: a -> Parser a
+return' v = \input -> [(v, input)]
+
+failure :: Parser a
+failure = \input -> []
+
+item :: Parser Char
+item = \input -> case input of
+ [] -> []
+ (x:xs) -> [(x, xs)]
+
+parse :: Parser a -> String -> [(a, String)]
+parse parser input = parser input
+
+-- Sequencing operator
+(>>>=) :: Parser a -> (a -> Parser b) -> Parser b
+p >>>= f = \input -> case parse p input of
+ [] -> []
+ [(v, out)] -> parse (f v) out
+
+p :: Parser (Char, Char)
+p = item >>>= \x ->
+ item >>>= \_ ->
+ item >>>= \y ->
+ return' (x, y)
+
+(+++) :: Parser a -> Parser a -> Parser a
+p +++ q = \input -> case parse p input of
+ [] -> parse q input
+ [(v, out)] -> [(v, out)]
+
+satisfies :: (Char -> Bool) -> Parser Char
+satisfies predicate = item >>>= \x -> if predicate x then return' x else failure
+
+digit :: Parser Char
+digit = satisfies isDigit
+
+lower :: Parser Char
+lower = satisfies isLower
+
+upper :: Parser Char
+upper = satisfies isUpper
+
+letter :: Parser Char
+letter = satisfies isAlpha
+
+alphanum :: Parser Char
+alphanum = satisfies isAlphaNum
+
+char :: Char -> Parser Char
+char x = satisfies (== x)
+
+string :: String -> Parser String
+string [] = return' []
+string (x:xs) = char x >>>= \_ ->
+ string xs >>>= \_ ->
+ return' (x:xs)
+
+many :: Parser a -> Parser [a]
+many p = many1 p +++ return' []
+
+many1 :: Parser a -> Parser [a]
+many1 p = p >>>= \v ->
+ many p >>>= \vs ->
+ return' (v:vs)
+
+ident :: Parser String
+ident = lower >>>= \x ->
+ many alphanum >>>= \xs ->
+ return' (x:xs)
+
+nat :: Parser Int
+nat = many1 digit >>>= \xs ->
+ return' (read xs)
+
+space :: Parser ()
+space = many (satisfies isSpace) >>>= \_ ->
+ return' ()
+
+token :: Parser a -> Parser a
+token p = space >>>= \_ ->
+ p >>>= \v ->
+ space >>>= \_ ->
+ return' v
+
+identifier :: Parser String
+identifier = token ident
+
+natural :: Parser Int
+natural = token nat
+
+symbol :: String -> Parser String
+symbol xs = token (string xs)
+
+list :: Parser [Int]
+list = symbol "[" >>>= \_ ->
+ natural >>>= \n ->
+ many (symbol "," >>>= \_ -> natural) >>>= \ns ->
+ symbol "]" >>>= \_ ->
+ return' (n:ns)
+
+-- Arithmetic BNF grammar
+-- expr ::= expr + expr | expr * expr | (expr) | nat
+-- nar ::= 0 | 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9
+
+-- expr ::= term ( + expr | - expr | '')
+-- term ::= factor (* term | / term | '')
+-- factor ::= (expr) | nat
+-- nat ::= 0 | 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9
+
+-- expr ::= term ( + expr | - expr | '')
+-- term ::= expo (* term | / term | '')
+-- factor ::= atom (^ factor | '')
+-- atom ::= (expr) | nat
+-- nat ::= 0 | 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9
+
+expr :: Parser Int
+expr = term >>>= \t ->
+ ((symbol "+" >>>= \_ ->
+ expr >>>= \e ->
+ return' (t + e))
+ +++
+ (symbol "-" >>>= \_ ->
+ expr >>>= \e ->
+ return' (t + e)))
+ +++ return' t
+
+term :: Parser Int
+term = factor >>>= \f ->
+ ((symbol "*" >>>= \_ ->
+ term >>>= \t ->
+ return' (f * t))
+ +++
+ (symbol "/" >>>= \_ ->
+ term >>>= \t ->
+ return' (f `div` t)))
+ +++ return' f
+
+factor :: Parser Int
+factor = atom >>>= \a ->
+ (symbol "^" >>>= \_ ->
+ factor >>>= \f ->
+ return' (a ^ f))
+ +++ return' a
+
+atom :: Parser Int
+atom = (symbol "(" >>>= \_ ->
+ expr >>>= \e ->
+ symbol ")" >>>= \_ ->
+ return' e)
+ +++ natural
+
+int :: Parser Int
+int = (symbol "-" >>>= \_ ->
+ nat >>>= \n ->
+ return' (-n))
+ +++ nat
+
+comment :: Parser ()
+comment = symbol "--" >>>= \_ ->
+ many (satisfies (/= '\n')) >>>= \_ ->
+ char '\n' >>>= \_ ->
+ return' ()
+
+getLine' :: IO String
+getLine' = do x <- getChar
+ if x == '\n' then
+ return []
+ else
+ do xs <- getLine'
+ return (x:xs)
+
+putStr' :: String -> IO ()
+putStr' [] = return ()
+putStr' (x:xs) = do putChar x
+ putStr xs
+
+putStrLn' :: String -> IO ()
+putStrLn' xs = do putStr xs
+ putChar '\n'
+
+strlen :: IO ()
+strlen = do putStr "Enter a string: "
+ xs <- getLine
+ putStr "The string has "
+ putStr (show (length xs))
+ putStrLn " characters"
+
+beep :: IO ()
+beep = putStr "\BEL"
+
+clearScreen :: IO ()
+clearScreen = putStr "\ESC[2J"
+
+type Pos = (Int, Int)
+
+goto :: Pos -> IO ()
+goto (x,y) = putStr ("\ESC[" ++ show y ++ ";" ++ show x ++ "H")
+
+writeAt :: Pos -> String -> IO ()
+writeAt pos xs = do goto pos
+ putStr xs
+
+seqn :: [IO a] -> IO ()
+seqn [] = return ()
+seqn (a:as) = do a
+ seqn as
+
+putStr'' :: String -> IO()
+putStr'' xs = seqn [putChar x | x <- xs]
+
+box :: [String]
+box = ["+---------------+",
+ "| |",
+ "+---+---+---+---+",
+ "| q | c | d | = |",
+ "+---+---+---+---+",
+ "| 1 | 2 | 3 | + |",
+ "+---+---+---+---+",
+ "| 4 | 5 | 6 | - |",
+ "+---+---+---+---+",
+ "| 7 | 8 | 9 | * |",
+ "+---+---+---+---+",
+ "| 0 | ( | ) | / |",
+ "+---+---+---+---+"]
+
+buttons :: [Char]
+buttons = standard ++ extra
+ where standard = "qcd=123+456-789*0()/"
+ extra = "QCD \ESC\BS\DEL\n"
+
+showbox :: IO ()
+showbox = seqn [writeAt (1,y) xs | (y,xs) <- zip [1..13] box]
+
+display :: String -> IO ()
+display xs = do writeAt (3,2) " "
+ writeAt (3,2) (reverse (take 13 (reverse xs)))
+
+calc :: String -> IO ()
+calc xs = do display xs
+ c <- getChar
+ if elem c buttons then
+ process c xs
+ else
+ do beep
+ calc xs
+
+process :: Char -> String -> IO ()
+process c xs
+ | elem c "qQ\ESC" = quit
+ | elem c "dD\BS\DEL" = delete xs
+ | elem c "=\n" = eval xs
+ | elem c "cC" = clear
+ | otherwise = press c xs
+
+quit :: IO ()
+quit = goto (1,14)
+
+delete :: String -> IO ()
+delete "" = calc ""
+delete xs = calc (init xs)
+
+eval :: String -> IO ()
+eval xs = case parse expr xs of
+ [(n,"")] -> calc (show n)
+ _ -> do beep
+ calc xs
+
+clear :: IO ()
+clear = calc ""
+
+press :: Char -> String -> IO ()
+press c xs = calc (xs ++ [c])
+
+run :: IO ()
+run = do clearScreen
+ showbox
+ clear
63 recursive-functions.hs
@@ -0,0 +1,63 @@
+-- Recursive definition of the exponentiation operator
+(.^.) :: Int -> Int -> Int
+a .^. 0 = 1
+a .^. (n + 1) = a * (a .^. n)
+
+and' :: [Bool] -> Bool
+and' [] = True
+and' (x:xs) = x && (and' xs)
+
+concat' :: [[a]] -> [a]
+concat' [] = []
+concat' (xs:xss) = xs ++ concat' xss
+
+replicate' :: Int -> a -> [a]
+replicate' 0 _ = []
+replicate' (n + 1) a = [a] ++ replicate' n a
+
+(.!!.) :: [a] -> Int -> a
+(x:_) .!!. 0 = x
+(x:xs) .!!. (n + 1) = xs .!!. n
+
+elem' :: Eq a => a -> [a] -> Bool
+elem' _ [] = False
+elem' e (x:xs) = e == x || elem' e xs
+
+merge :: Ord a => [a] -> [a] -> [a]
+merge xs [] = xs
+merge [] ys = ys
+merge (x:xs) (y:ys) | x <= y = x : merge xs (y:ys)
+ | otherwise = y : merge (x:xs) ys
+
+-- Merge sort
+msort :: Ord a => [a] -> [a]
+msort [] = []
+msort [x] = [x]
+msort xs = merge (msort first) (msort second)
+ where first = fst (halve xs)
+ second = snd (halve xs)
+ halve xs = splitAt middle xs
+ middle = (length xs) `div` 2
+
+sum' :: Num a => [a] -> a
+sum' [] = 0
+sum' (x:xs) = x + sum' xs
+
+take' :: Int -> [a] -> [a]
+take' _ [] = []
+take' 0 xs = xs
+take' (n + 1) (x:xs) = take' n xs
+
+last' :: [a] -> a
+last' [x] = x
+last' (x:xs) = last' xs
+
+-- Insertion sort
+insert :: Ord a => a -> [a] -> [a]
+insert x [] = [x]
+insert x (y:ys) | x <= y = x : y : ys
+ | otherwise = y : insert x ys
+
+isort :: Ord a => [a] -> [a]
+isort [] = []
+isort (x:xs) = insert x (isort xs)
BIN solutions.pdf
Binary file not shown.
108 spikes.hs
@@ -0,0 +1,108 @@
+import Char (ord, chr, isLower)
+
+halve :: [a] -> ([a], [a])
+halve xs = splitAt middle xs
+ where middle = length xs `div` 2
+
+safetail :: [a] -> [a]
+safetail [] = []
+safetail (x:xs) = xs
+
+safetail' :: [a] -> [a]
+safetail' xs = if null xs then xs else tail xs
+
+safetail'' :: [a] -> [a]
+safetail'' xs | null xs = xs
+ | otherwise = tail xs
+
+(.||.) :: Bool -> Bool -> Bool
+True .||. _ = True
+False .||. b = b
+
+(.&&.) :: Bool -> Bool -> Bool
+-- a .&&. b = if a then if b then True else False else False
+a .&&. b = if a then b else False
+
+mult :: Num a => a -> a -> a -> a
+mult = \x -> \y -> \z -> x * y * z
+
+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 <- [1..n], prime x]
+
+let2int :: Char -> Int
+let2int c = ord c - ord 'a'
+
+int2let :: Int -> Char
+int2let n = chr (ord 'a' + n)
+
+shift :: Int -> Char -> Char
+shift n char | isLower char = int2let ((let2int char + n) `mod` 26)
+ | otherwise = char
+
+-- Caesar's cipher
+encode :: Int -> String -> String
+encode factor xs = [shift factor x | x <- xs]
+
+lowers :: String -> Int
+lowers xs = length [x | x <- xs, isLower x]
+
+count :: Char -> String -> Int
+count char inString = length [c | c <- inString, c == char]
+
+letterFreqs :: [Float]
+letterFreqs = [8.2, 1.5, 2.8, 4.3, 12.7, 2.2, 2.0, 6.1, 7.0, 0.2, 0.8, 4.0, 2.4,
+ 6.7, 7.5, 1.9, 0.1, 6.0, 6.3, 9.1, 2.8, 1.0, 2.4, 0.2, 2.0, 0.1]
+
+percent :: Int -> Int -> Float
+percent n m = (fromIntegral n / fromIntegral m) * 100
+
+freqs :: String -> [Float]
+freqs xs = [percent (count x xs) n | x <- ['a'..'z']]
+ where n = lowers xs
+
+chiSquare :: [Float] -> [Float] -> Float
+chiSquare observedFreqs expectedFreqs = sum [(o - e)^2 / e | (o,e) <- zip observedFreqs expectedFreqs]
+
+rotate :: Int -> [a] -> [a]
+rotate n xs = drop n xs ++ take n xs
+
+positions :: Eq a => a -> [a] -> [Int]
+positions x xs = [i | (x', i) <- zip xs [0..n], x == x']
+ where n = length xs - 1
+
+find :: Eq a => a -> [(a, b)] -> [b]
+find key pairs = [pair | (k, pair) <- pairs, k == key]
+
+positions' :: Eq a => a -> [a] -> [Int]
+positions' x xs = find x (zip xs [0..n])
+ where n = length xs - 1
+
+crack :: String -> String
+crack xs = encode (-factor) xs
+ where factor = head (positions (minimum chiTable) chiTable)
+ chiTable = [chiSquare (rotate n table') letterFreqs | n <- [0..25]]
+ table' = freqs xs
+
+sumOfSquares :: Int -> Int
+sumOfSquares n = sum [x^2 | x <- [1..n]]
+
+replicate' :: Int -> a -> [a]
+replicate' n x = [x | _ <- [1..n]]
+
+pythagoreanNumbers :: Int -> [(Int, Int, Int)]
+pythagoreanNumbers n = [(x, y, z) | x <- [1..n], y <- [1..n], z <- [1..n], x^2 + y^2 == z^2]
+
+perfects :: Int -> [Int]
+perfects n = [x | x <- [1..n], x == sum (init (factors x))]
+
+test :: [(Int, Int)]
+test = [(x, y) | x <- [1,2,3], y <- [4,5,6]]
+
+scalarproduct :: Num a => [a] -> [a] -> a
+scalarproduct xs ys = sum [x*y | (x, y) <- zip xs ys]
23 test.hs
@@ -0,0 +1,23 @@
+product' :: Num a => [a] -> a
+product' [] = 1
+product' (x:xs) = x * product' xs
+
+double :: Num a => a -> a
+double x = x + x
+
+quadruple :: Num a => a -> a
+quadruple = double . double
+
+last' = head . reverse
+last'' xs = xs !! (length xs - 1)
+
+init' = reverse . tail . reverse
+init'' xs = take (length xs - 1) xs
+
+swap (x,y) = (y,x)
+
+pair x y = (x,y)
+
+palindrome xs = reverse xs == xs
+
+twice f = f . f

0 comments on commit 6d5df9f

Please sign in to comment.
Something went wrong with that request. Please try again.