Learning Haskell - Programming in Haskell - Graham Hutton

Main.hs

module Main where

import Lib
import Data.Char
import Prelude
import Text.Printf

main :: IO ()
main = someFunc

qsort [] = []
qsort (x:xs) = qsort smaller ++ [x] ++ qsort larger
               where
                smaller = [a | a <- xs, a <= x]
                larger  = [b | b <- xs, b > x]

--qsort [3,5,1,4,2]
seqn :: [IO a] -> IO [a]
seqn [] = return []
seqn (act:acts) = do x <- act
                     xs <- seqn acts
                     return (x:xs)

factorial n = product [1..n]

average ns = sum ns `div` length ns

add x y = x + y

-- Pattern matching

--(&&) :: Bool -> Bool -> Bool
--True && True = True
--_    && _    = False


-- lambda expressions
a = \ x -> x + x

addL :: Int -> (Int -> Int)
addL = \ x -> \ y -> x + y

add2 = addL 2

-- function declaration is right associative
-- function application is left associative

-- luhn algorithm
luhnDouble :: Int -> Int
luhnDouble x = y - (if y > 9 then 9 else 0) where y = x * 2

--luhn :: Int -> Int -> Int -> Int -> Bool
--luhn a b c d = sum (map luhnDouble [a,c]) `mod` 10 == 0

-- guards
--find :: Eq a => a -> [(a,b)] -> [b]
--find k t = [v | (k', v) <- t, k == k']

-- zip
pairs :: [a] -> [(a,a)]
pairs xs = zip xs (tail xs)

sorted :: Ord a => [a] -> Bool
sorted xs = and [x <= y | (x,y) <- pairs xs]

positions :: Eq a => a -> [a] -> [Int]
positions x xs = [i | (x', i) <- zip xs [0..], x == x']

-- Caesar Cipher
let2int :: Char -> Int
let2int c = ord c - ord 'a'

int2let :: Int -> Char
int2let n = chr (ord 'a' + n)

shift :: Int -> Char -> Char
shift n c | isLower c = int2let ((let2int c + n) `mod` 26)
          | otherwise = c

--encode :: Int -> String -> String
--encode n xs = [shift n x | x <- xs]

percent :: Int -> Int -> Float
percent n m = (fromIntegral n / fromIntegral m) * 100

count :: Eq a => a -> [a] -> Int
count x xs = sum [1 | x' <- xs, x == x']

lowers :: String -> Int
lowers xs = length [x | x <- xs, isAsciiLower x]

freqs :: String -> [Float]
freqs xs = [percent (count x xs) n | x <- ['a'..'z']]
            where
            n = lowers xs


-------------
-- Recursion
-- Some of the implementations are commented because they are
-- overriding the existing definitions in scope
-------------
fac :: Int -> Int
fac 0 = 1
fac n = n * fac(n-1)

--product :: Num a => [a] -> a
--product [] = 1
--product (n:ns) = n * product ns

--length :: [a] -> Int
--length [] = 0
--length (_:xs) = 1 + length xs

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

-- commented because above qsort code is using system ++
--(++) :: [a] -> [a] -> [a]
--[] ++ ys = ys
--(x:xs) ++ ys = x : (xs :: ys)

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)

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

--drop :: Int -> [a] -> [a]
--drop 0 xs = xs
--drop _ [] = []
--drop n (_:xs) = drop (n-1) xs

fib :: Int -> Int
fib 0 = 0
fib 1 = 1
fib n = fib (n-2) + fib(n-1)

-- mutual recursion
--even :: Int -> Bool
--even 0 = True
--even n = odd (n-1)
--
--odd :: Int -> Bool
--odd = False
--odd n = even (n + 1)

evens :: [a] -> [a]
evens []     = []
evens (x:xs) = x : odds xs

odds :: [a] -> [a]
odds []     = []
odds (x:xs) = evens xs


-------------------------
-- Higher order functions
-------------------------
twice :: (a -> a) -> a -> a
twice f x = f (f x)

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

--filter :: (a -> Bool) -> [a] -> [a]
--filter p xs = [x | x <- xs, p x]
-- filter using recursion
--filter p [] = []
--filter p (x:xs) | p x = x : filter p xs
--                | otherwise filter p xs

--foldr :: (a -> b -> b) -> b -> [a] -> b
--foldr f v [] = v
--foldr f v (x:xs) = f x (foldr f v xs)

--foldl :: (a -> b -> a) -> a -> [b] -> a
--foldl f v [] = v
--foldl f v (x:xs) = foldl f (f v x) xs

--sum :: Num a => [a] -> a
--sum = sum' 0
--      where
--        sum' v [] = v
--        sum' v (x:xs) = sum' (v+x) xs

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

type Bit = Int
bin2int :: [Bit] -> Int
bin2int bits = sum [w*b | (w,b) <- zip weights bits]
               where weights = iterate (*2) 1

int2bin :: Int -> [Bit]
int2bin 0 = []
int2bin n = n `mod` 2 : int2bin(n `div` 2)

make8 :: [Bit] -> [Bit]
make8 bits = take 8 (bits ++ repeat 0)

encode :: String -> [Bit]
encode = concatMap (make8 . int2bin . ord)

chop8 :: [Bit] -> [[Bit]]
chop8 [] = []
chop8 bits = take 8 bits : chop8 (drop 8 bits)

decode :: [Bit] -> String
decode = map (chr . bin2int) . chop8

------------------------------
-- Declaring types and classes
------------------------------

type Pair a = (a,a)
type Assoc k v = [(k,v)]

find :: Eq k => k -> Assoc k v -> v
find k t = head [v | (k', v) <- t, k == k']

data Move = North | South | East | West


type Pos = (Int, Int)

move :: Move -> Pos -> Pos
move North (x,y) = (x, y+1)
move South (x,y) = (x, y-1)
move East  (x,y) = (x+1, y)
move West  (x,y) = (x-1, y)

data Shape = Circle Float | Rect Float Float
area :: Shape -> Float
area (Circle r) = pi * r^2
area (Rect l b) = l * b

safediv :: Int -> Int -> Maybe Int
safediv _ 0 = Nothing
safediv m n = Just (m `div` n)

-- Natural Numbers

data Nat = Zero | Succ Nat

instance Show Nat where
         show Zero     = "Zero"
         show (Succ m) = printf "Succ (%s)" (show m)

nat2int :: Nat -> Int
nat2int Zero = 0
nat2int (Succ n) = 1 + nat2int n

int2nat :: Int -> Nat
int2nat 0 = Zero
int2nat n = Succ (int2nat (n-1))

add' :: Nat -> Nat -> Nat
add' Zero n = n
add' (Succ m) n = Succ (add' m n)

addNat :: Nat -> Nat -> Nat
addNat m n = int2nat (nat2int m + nat2int n)

-- List

data List' a = Nil | Cons a (List' a)

len :: List' a -> Int
len Nil = 0
len (Cons _ xs) = 1 + len xs

-- Tree

data Tree a = Leaf a | Node (Tree a) a (Tree a)
t :: Tree Int
t = Node (Node (Leaf 1) 3 (Leaf 4))
         5
         (Node (Leaf 6) 7 (Leaf 9))

occurs :: Eq a => a -> Tree a -> Bool
occurs x (Leaf y)     = x == y
occurs x (Node l y r) = (x == y) || occurs x l || occurs x r

flatten :: Tree a -> [a]
flatten (Leaf x) = [x]
flatten (Node l x r) = flatten l ++ [x] ++ flatten r

occurs' :: Ord a => a -> Tree a -> Bool
occurs' x (Leaf y)   = x == y
occurs' x (Node l y r) | x == y    = True
                     | x < y     = occurs x l
                     | otherwise = occurs x r

-- class

class Bird a where
  eat, walk, fly :: () -> a

-- Tautology checker

data Prop = Const Bool
          | Var Char
          | Not Prop
          | And Prop Prop
          | Imply Prop Prop

p1 :: Prop
p1 = And (Var 'A') (Not (Var 'A'))

p2 :: Prop
p2 = Imply (And (Var 'A') (Var 'B')) (Var 'A')

p3 :: Prop
p3 = Imply (Var 'A') (And (Var 'A') (Var 'B'))

p4 :: Prop
p4 = Imply (And (Var 'A') (Imply (Var 'A') (Var 'B'))) (Var 'B')

type Subst = Assoc Char Bool

eval :: Subst -> Prop -> Bool
eval _ (Const b)   = b
eval s (Var x)     = find x s
eval s (Not p)     = not (eval s p)
eval s (And p q)   = eval s p && eval s q
eval s (Imply p q) = eval s p <= eval s q

vars :: Prop -> [Char]
vars (Const _)   = []
vars (Var x)     = [x]
vars (Not p)     = vars p
vars (And p q)   = vars p ++ vars q
vars (Imply p q) = vars p ++ vars q

bools :: Int -> [[Bool]]
bools n = map (reverse . map conv . make n . int2bin) range
          where
            range     = [0..(2^n)-1]
            make n bs = take n (bs ++ repeat 0)
            conv 0    = False
            conv 1    = True

rmdups :: Eq a => [a] -> [a]
rmdups []     = []
rmdups (x:xs) = x : filter (/= x) (rmdups xs)

substs :: Prop -> [Subst]
substs p = map (zip vs) (bools (length vs))
              where vs = rmdups (vars p)

isTaut :: Prop -> Bool
isTaut p = and [eval s p | s <- substs p]

-- Abstract Machine

data Expr = Val Int | Add Expr Expr

value :: Expr -> Int
value (Val n)   = n
value (Add x y) = value x + value y

type Cont = [Op]

data Op = EVAL Expr | ADD Int

eval' :: Expr -> Cont -> Int
eval' (Val n)   c = exec c n
eval' (Add x y) c = eval' x (EVAL y : c)

exec :: Cont -> Int -> Int
exec [] n           = n
exec (EVAL y : c) n = eval' y (ADD n : c)
exec (ADD  n : c) m = exec c (n+m)

value :: Expr -> Int
value e = eval e []