UCSD CSE 230 Winter 2014 HW3

Hw3.lhs

---
Homework #3, Due Monday, March 2nd 2015 (23:59:59 PST) 
---

Preliminaries
=============

Before starting this part of the assignment, 

1. Install the following packages 

~~~~~{.haskell}
$ cabal install quickcheck
~~~~~

2. Learn to read the [documentation](http://hackage.haskell.org)

To complete this homework, download [this file](/homeworks/Hw3.lhs) 
as plain text and answer each question, filling in code where it says
`"TODO"`. Your code must typecheck against the given type signatures. 
Feel free to add your own tests to this file to exercise the 
functions you write. Submit your homework by sending this file, 
filled in appropriately, to cse230@goto.ucsd.edu with the subject
“HW3”; you will receive a confirmation email after submitting. 
Please note that this address is unmonitored; if you have any 
questions about the assignment, post to Piazza.

> {-# LANGUAGE TypeSynonymInstances, FlexibleContexts, NoMonomorphismRestriction, OverlappingInstances, FlexibleInstances #-}
> {-# OPTIONS -Wall -fno-warn-unused-do-bind #-}

> import qualified Data.Map as Map

> import Control.Monad.State
> import Control.Monad.Error
> import Control.Monad.Writer

> import Test.QuickCheck hiding ((===))
> import Control.Monad (forM, forM_)
> import Data.List (transpose, intercalate)


> quickCheckN n = quickCheckWith $ stdArgs { maxSuccess = n}

Problem 0: All About You
========================

Tell us your name, email and student ID, by replacing the respective
strings below

> myName  = "Martin Bjeldbak Madsen"
> myEmail = "ax003222@acsmail.ucsd.edu"
> mySID   = "U06616356"

Problem 1: Binary Search Trees Revisited 
========================================

Recall the old type of binary search trees from
[HW2](http://cseweb.ucsd.edu/classes/wi15/cse230-a/homeworks/Hw2.html).

> data BST k v = Emp 
>              | Bind k v (BST k v) (BST k v) 
>              deriving (Show)
> 
> toBinds                ::  BST t t1 -> [(t, t1)]
> toBinds Emp            = []
> toBinds (Bind k v l r) = toBinds l ++ [(k,v)] ++ toBinds r

The following function tests whether a tree satisfies the 
binary-search-order invariant.

> isBSO                ::  Ord a => BST a b -> Bool
> isBSO Emp            = True
> isBSO (Bind k v l r) = all (< k) lks && all (k <) rks && isBSO l && isBSO r
>   where lks = map fst $ toBinds l
>         rks = map fst $ toBinds r

Finally, to test your implementation, we will define a 
type of operations over trees

> data BSTop k v = BSTadd k v | BSTdel k 
>                  deriving (Eq, Show)

and a function that constructs a tree from a sequence of operations

> ofBSTops ::  Ord k => [BSTop k v] -> BST k v
> ofBSTops    = foldr doOp Emp
>   where doOp (BSTadd k v) = bstInsert k v 
>         doOp (BSTdel k)   = bstDelete k 

and that constructs a reference `Map` from a sequence of operations

> mapOfBSTops ::  Ord k => [BSTop k a] -> Map.Map k a
> mapOfBSTops = foldr doOp Map.empty 
>   where doOp (BSTadd k v) = Map.insert k v
>         doOp (BSTdel k)   = Map.delete k

and functions that generate an arbitrary BST operations

> keys :: [Int] 
> keys = [0..10]
>
> genBSTadd, genBSTdel, genBSTop ::  Gen (BSTop Int Char)
> genBSTadd = liftM2 BSTadd (elements keys) (elements ['a'..'z'])
> genBSTdel = liftM BSTdel (elements keys)
> genBSTop  = frequency [(5, genBSTadd), (1, genBSTdel)] 

(a) Insertion
-------------

Write an insertion function 

> bstInsert :: (Ord k) => k -> v -> BST k v -> BST k v
> bstInsert k v (Bind k' v' l r)
>   | k == k' = Bind k' v l r
>   | k < k'  = bstInsRebal k (Bind k' v' (bstInsert k v l) r)
>   | k > k'  = bstInsRebal k (Bind k' v' l (bstInsert k v r))
> bstInsert k v Emp = Bind k v Emp Emp


such that `bstInsert k v t` inserts a key `k` with value 
`v` into the tree `t`. If `k` already exists in the input
tree, then its value should be *replaced* with `v`. When you 
are done, your code should satisfy the following QC properties.

> prop_insert_bso :: Property
> prop_insert_bso = forAll (listOf genBSTadd) $ \ops -> 
>                     isBSO (ofBSTops ops)
>
> prop_insert_map = forAll (listOf genBSTadd) $ \ops -> 
>                     toBinds (ofBSTops ops) == Map.toAscList (mapOfBSTops ops)

(b) Deletion
------------

Write a deletion function for BSTs of this type:

I'm using the same delete function from Hw2. First we have the function to find the minimum key and value in a sub-tree. From homework 2.

> minKeyVal :: (Ord k) => BST k v -> (k, v)
> minKeyVal (Bind k v Emp _) = (k, v)
> minKeyVal (Bind _ _ l _) = minKeyVal l
> minKeyVal Emp            = error "Cannot find the min (k,v) in empty tree"

Now to the delete method itself (copied from HW2).

> bstDelete :: (Ord k) => k -> BST k v -> BST k v
> bstDelete _ Emp = Emp 
> bstDelete k (Bind k' v Emp Emp)
>  | k == k'   = Emp 
>  | otherwise = Bind k' v Emp Emp
> bstDelete k (Bind k' v l Emp)
>  | k > k'  = Bind k' v l Emp 
>  | k < k'  = bstDelRebal $ Bind k' v (bstDelete k l) Emp
>  | k == k' = l -- push left tree up
> bstDelete k (Bind k' v Emp r)
>  | k < k'  = Bind k' v Emp r
>  | k > k'  = bstDelRebal $ Bind k' v Emp (bstDelete k r)
>  | k == k' = r -- push right tree up
> bstDelete k (Bind k' v l r)
>  | k < k'  = bstDelRebal $ Bind k' v (bstDelete k l) r
>  | k > k'  = bstDelRebal $ Bind k' v l (bstDelete k r)
>  | k == k' = Bind mink minv l r' 
>      where (mink, minv) = minKeyVal r
>            r'           = bstDelete mink r

such that `bstDelete k t` removes the key `k` from the tree `t`. 
If `k` is absent from the input tree, then the tree is returned 
unchanged as the output. When you are done, your code should 
satisfy the following QC properties.

> prop_delete_bso :: Property
> prop_delete_bso = forAll (listOf genBSTop) $ \ops -> 
>                     isBSO (ofBSTops ops)
>
> prop_delete_map = forAll (listOf genBSTop) $ \ops -> 
>                     toBinds (ofBSTops ops) == Map.toAscList (mapOfBSTops ops)


(c) Balanced Trees  
------------------

The following function determines the `height` of a BST 

> height (Bind _ _ l r) = 1 + max (height l) (height r)
> height Emp            = 0

We say that a tree is *balanced* if 

> isBal (Bind _ _ l r) = isBal l && isBal r && abs (height l - height r) <= 2
> isBal Emp            = True

Write a balanced tree generator 

First, I tried implementing the below, and, like in lecture, it makes infinite size tress.

>-- instance Arbitrary (BST Int Char) where
>--   arbitrary = liftM4 Bind choose (0,999)
>--                           elements ['A' .. 'Z']
>--                           arbitrary
>--                           arbitrary

Then I went on to follow the idea from lecture too, where this is a little simpler. The base case is simply to generate a trivially balanced tree. The recursive case simply builds these trivially balanced trees on top of each other.

> genBal' :: Int -> (BST Int Char) -> Gen (BST Int Char)
> genBal' 0 t   = return t -- should also match Emp
> genBal' n Emp = return Emp
> genBal' n (Bind k v l r) = do klt <- choose (0, k-1)
>                               kgt <- choose (k+1, 999)
>                               v' <- elements ['A' .. 'Z']
>                               let ltBST = bstInsert klt v' (Bind k v l r)
>                                   gtBST = bstInsert kgt v' (Bind k v l r)
>                                   nBy2  = n `div` 2
>                               if isBal ltBST
>                               then genBal' nBy2 ltBST
>                               else if isBal gtBST
>                               then genBal' nBy2 gtBST 
>                               else genBal' nBy2 (Bind k v l r)

> genBal :: Gen (BST Int Char)
> genBal = genBal' 1000 (Bind 200 'A' Emp Emp)

such that

> prop_genBal = forAll genBal isBal

(d) Height Balancing (** Hard **) 
---------------------------------

Rig it so that your insert and delete functions *also*
create balanced trees. That is, they satisfy the properties

> prop_insert_bal ::  Property
> prop_insert_bal = forAll (listOf genBSTadd) $ isBal . ofBSTops 
>
> prop_delete_bal ::  Property
> prop_delete_bal = forAll (listOf genBSTop) $ isBal . ofBSTops

I updated the `bstInsert` and `bstDelete` methods from HW2 above to include a rebalancing function on each insert or deletion. Them and their auxilarary functions (rotations) can be seen below.

The following two functions do right and left rotations on trees

> bstRotateR :: (Ord k) => BST k v -> BST k v
> bstRotateR Emp = Emp
> bstRotateR (Bind z zv (Bind y yv x t3) t4) = 
>   Bind y yv x (Bind z zv t3 t4)
> bstRotateR t = t -- anything else doesn't need to be rotated

> bstRotateL :: (Ord k) => BST k v -> BST k v
> bstRotateL Emp = Emp
> bstRotateL (Bind z zv t1 (Bind y yv t2 x)) =
>   Bind y yv (Bind z zv t1 t2) x
> bstRotateL t = t -- anything else doesn't need to be rotated

The following function determines the balance factor to determine whether the tree is unbalanced or not and is in need of a rotation

> bFac :: (Ord k) => BST k v -> Integer
> bFac Emp = 0
> bFac (Bind k v l r) = height l - height r

Balanced insert is enhanced with this function I've written, that rebalances a tree `t` after insertion of `k'` has happened. I have updated my `bstInsert` to include this function after each insert.

> bstInsRebal :: (Ord k) => k -> BST k v -> BST k v
> bstInsRebal _ Emp = Emp
> bstInsRebal k' t@(Bind k v l@(Bind kl _ _ _) r)
>   | bFac t > 1 && k' < kl = bstRotateR t -- ll case
>   | bFac t > 1 && k' > kl = bstRotateR $ Bind k v (bstRotateL l) r -- lr case
>   | abs (bFac t) < 2 = t -- we're good, don't need to rebalance
> bstInsRebal k' t@(Bind k v l r@(Bind kr _ _ _))
>   | bFac t < (-1) && k' > kr = bstRotateL t -- rr case
>   | bFac t < (-1) && k' < kr = bstRotateL $ Bind k v l (bstRotateR r) -- rl case
>   | abs (bFac t) < 2 = t -- we're good, don't need to balance
> bstInsRebal _ t = t -- anything else doesn't need to be balanced (this case should never be matched, but GHC complains)

The following funciton, `bstDelRebal` rebalances a tree after a node has been deleted. It has also been injected into the code for `bstDelete`.

> bstDelRebal :: (Ord k) => BST k v -> BST k v
> bstDelRebal Emp = Emp
> bstDelRebal t@(Bind k v l r)
>   | bFac t > 1    && bFac l >= 0 = bstRotateR t -- ll case
>   | bFac t > 1    && bFac l < 0  = bstRotateR $ Bind k v (bstRotateL l) r
>   | bFac t < (-1) && bFac r <= 0 = bstRotateL t -- rr case
>   | bFac t < (-1) && bFac r > 0  = bstRotateL $ Bind k v l (bstRotateR r)
>   | abs (bFac t) < 2 = t -- we're good, don't need to rebalance
> bstDelRebal t = t


Problem 2: Circuit Testing
==========================

Credit: [UPenn CIS552][1]

For this problem, you will look at a model of circuits in Haskell.

Signals
-------

A *signal* is a list of booleans.  

> newtype Signal = Sig [Bool]

By convention, all signals are infinite. We write a bunch of lifting
functions that lift boolean operators over signals.

> lift0 ::  Bool -> Signal
> lift0 a = Sig $ repeat a
> 
> lift1 ::  (Bool -> Bool) -> Signal -> Signal
> lift1 f (Sig s) = Sig $ map f s
> 
> lift2 ::  (Bool -> Bool -> Bool) -> (Signal, Signal) -> Signal
> lift2 f (Sig xs, Sig ys) = Sig $ zipWith f xs ys
> 
> lift22 :: (Bool -> Bool -> (Bool, Bool)) -> (Signal, Signal) -> (Signal,Signal)
> lift22 f (Sig xs, Sig ys) = 
>   let (zs1,zs2) = unzip (zipWith f xs ys)
>   in (Sig zs1, Sig zs2) 
> 
> lift3 :: (Bool->Bool->Bool->Bool) -> (Signal, Signal, Signal) -> Signal
> lift3 f (Sig xs, Sig ys, Sig zs) = Sig $ zipWith3 f xs ys zs
> 

Simulation
----------

Next, we have some helpers that can help us simulate a circuit by showing
how it behaves over time. For testing or printing, we truncate a signal to 
a short prefix 

> truncatedSignalSize = 20
> truncateSig bs = take truncatedSignalSize bs
> 
> instance Show Signal where
>   show (Sig s) = show (truncateSig s) ++ "..."
> 
> trace :: [(String, Signal)] -> Int -> IO ()
> trace desc count = do 
>   putStrLn   $ intercalate " " names
>   forM_ rows $ putStrLn . intercalate " " . rowS
>   where (names, wires) = unzip desc
>         rows           = take count . transpose . map (\ (Sig w) -> w) $ wires
>         rowS bs        = zipWith (\n b -> replicate (length n - 1) ' ' ++ (show (binary b))) names bs
> 
> probe :: [(String,Signal)] -> IO ()
> probe desc = trace desc 1
> 
> simulate :: [(String, Signal)] -> IO ()
> simulate desc = trace desc 20

Testing support (QuickCheck helpers)
------------------------------------

Next, we have a few functions that help to generate random tests

> instance Arbitrary Signal where
>   arbitrary = do 
>     x      <- arbitrary
>     Sig xs <- arbitrary
>     return $ Sig (x : xs)
> 
> arbitraryListOfSize n = forM [1..n] $ \_ -> arbitrary

To check whether two values are equivalent 

> class Agreeable a where
>   (===) :: a -> a -> Bool
> 
> instance Agreeable Signal where
>   (Sig as) === (Sig bs) = 
>     all (\x->x) (zipWith (==) (truncateSig as) (truncateSig bs))
> 
> instance (Agreeable a, Agreeable b) => Agreeable (a,b) where
>   (a1,b1) === (a2,b2) = (a1 === a2) && (b1 === b2)
> 
> instance Agreeable a => Agreeable [a] where
>   as === bs = all (\x->x) (zipWith (===) as bs)
> 

To convert values from boolean to higher-level integers

> class Binary a where
>   binary :: a -> Integer
> 
> instance Binary Bool where
>   binary b = if b then 1 else 0
> 
> instance Binary [Bool] where
>   binary = foldr (\x r -> (binary x) + 2 *r) 0

And to probe signals at specific points.

> sampleAt n (Sig b) = b !! n
> sampleAtN n signals = map (sampleAt n) signals
> sample1 = sampleAt 0
> sampleN = sampleAtN 0


Basic Gates
-----------

The basic gates from which we will fashion circuits can now be described.

> or2 ::  (Signal, Signal) -> Signal
> or2 = lift2 $ \x y -> x || y 
> 
> xor2 :: (Signal, Signal) -> Signal
> xor2 = lift2 $ \x y -> (x && not y) || (not x && y)
> 
> and2 :: (Signal, Signal) -> Signal
> and2 = lift2 $ \x y -> x && y 
> 
> imp2 ::  (Signal, Signal) -> Signal
> imp2 = lift2 $ \x y -> (not x) || y 
>
> mux :: (Signal, Signal, Signal) -> Signal
> mux = lift3 (\b1 b2 select -> if select then b1 else b2)
>
> demux :: (Signal, Signal) -> (Signal, Signal)
> demux args = lift22 (\i select -> if select then (i, False) else (False, i)) args
>
> muxN :: ([Signal], [Signal], Signal) -> [Signal]
> muxN (b1,b2,sel) = map (\ (bb1,bb2) -> mux (bb1,bb2,sel)) (zip b1 b2)
>
> demuxN :: ([Signal], Signal) -> ([Signal], [Signal])
> demuxN (b,sel) = unzip (map (\bb -> demux (bb,sel)) b)


Basic Signals 
-------------

Similarly, here are some basic signals

> high = lift0 True
> low  = lift0 False
>
> str   ::  String -> Signal
> str cs = Sig $ (map (== '1') cs) ++ (repeat False)
>
> delay ::  Bool -> Signal -> Signal
> delay init (Sig xs) = Sig $ init : xs


Combinational circuits
----------------------

**NOTE** When you are asked to implement a circuit, you must **ONLY** use
the above gates or smaller circuits built from the gates.

For example, the following is a *half-adder* (that adds a carry-bit to a
single bit).

> halfadd :: (Signal, Signal) -> (Signal, Signal)
> halfadd (x,y) = (sum,cout)
>   where sum   = xor2 (x, y)
>         cout  = and2 (x, y)


Here is a simple property about the half-adder

> prop_halfadd_commut b1 b2 =
>   halfadd (lift0 b1, lift0 b2) === halfadd (lift0 b2, lift0 b1) 

We can use the half-adder to build a full-adder

> fulladd (cin, x, y) = (sum, cout)
>   where (sum1, c1)  = halfadd (x,y)
>         (sum, c2)   = halfadd (cin, sum1)
>         cout        = xor2 (c1,c2) 
> 
> test1a = probe [("cin",cin), ("x",x), ("y",y), ("  sum",sum), ("cout",cout)]
>   where cin        = high
>         x          = low
>         y          = high
>         (sum,cout) = fulladd (cin, x, y)

and then an n-bit adder

> bitAdder :: (Signal, [Signal]) -> ([Signal], Signal)
> bitAdder (cin, [])   = ([], cin)
> bitAdder (cin, x:xs) = (sum:sums, cout)
>   where (sum, c)     = halfadd (cin,x)
>         (sums, cout) = bitAdder (c,xs)
>
> test1 = probe [("cin",cin), ("in1",in1), ("in2",in2), ("in3",in3), ("in4",in4),
>                ("  s1",s1), ("s2",s2), ("s3",s3), ("s4",s4), ("c",c)]
>   where
>     cin = high
>     in1 = high
>     in2 = high
>     in3 = low
>     in4 = high
>     ([s1,s2,s3,s4], c) = bitAdder (cin, [in1,in2,in3,in4])

The correctness of the above circuit is described by the following property
that compares the behavior of the circuit to the *reference implementation*
which is an integer addition function

> prop_bitAdder_Correct ::  Signal -> [Bool] -> Bool
> prop_bitAdder_Correct cin xs =
>   binary (sampleN out ++ [sample1 cout]) == binary xs + binary (sample1 cin)
>   where (out, cout) = bitAdder (cin, map lift0 xs) 
 
Finally, we can use the bit-adder to build an adder that adds two N-bit numbers

> adder :: ([Signal], [Signal]) -> [Signal]
> adder (xs, ys) = 
>    let (sums,cout) = adderAux (low, xs, ys)
>    in sums ++ [cout]
>    where                                        
>      adderAux (cin, [], [])     = ([], cin)
>      adderAux (cin, x:xs, y:ys) = (sum:sums, cout)
>                                   where (sum, c) = fulladd (cin,x,y)
>                                         (sums,cout) = adderAux (c,xs,ys)
>      adderAux (cin, [], ys)     = adderAux (cin, [low], ys)
>      adderAux (cin, xs, [])     = adderAux (cin, xs, [low])
> 
> test2 = probe [ ("x1", x1), ("x2",x2), ("x3",x3), ("x4",x4),
>                 (" y1",y1), ("y2",y2), ("y3",y3), ("y4",y4), 
>                 (" s1",s1), ("s2",s2), ("s3",s3), ("s4",s4), (" c",c) ]
>   where xs@[x1,x2,x3,x4] = [high,high,low,low]
>         ys@[y1,y2,y3,y4] = [high,low,low,low]
>         [s1,s2,s3,s4,c]  = adder (xs, ys)

And we can specify the correctness of the adder circuit by

> prop_Adder_Correct ::  [Bool] -> [Bool] -> Bool
> prop_Adder_Correct l1 l2 = 
>   binary (sampleN sum) == binary l1 + binary l2
>   where sum = adder (map lift0 l1, map lift0 l2) 

Problem: Subtraction
--------------------

1. Using `prop_bitAdder_Correct` as a model, write a specification for a
single-bit subtraction function that takes as inputs a N-bit binary 
number and a single bit to be subtracted from it and yields as
outputs an N-bit binary number. Subtracting one from zero should
yield zero.

> prop_bitSubtractor_Correct ::  Signal -> [Bool] -> Bool
> prop_bitSubtractor_Correct cin xs =
>   checkBorrow == subRes 
>   where (out, bout) = bitSubtractor (cin, map lift0 xs) 
>         o1 = sampleN out -- result of the subtraction
>         b1 = binary xs -- convert input bool arr to int
>         b2 = binary $ sample1 cin -- convert signal to int (so 0, 1)
>         subRes = if b1 >= b2 then b1 - b2 else 0 -- b1 can be less than b2
>         hasBorrowed = sample1 bout
>         checkBorrow = if hasBorrowed then
>                         binary $ map not o1 -- flip signals, convert
>                       else
>                         binary o1 -- just convert output to int

2. Using the `bitAdder` circuit as a model, define a `bitSubtractor` 
circuit that implements this functionality and use QC to check that 
your behaves correctly.

First, I define a `not` function for signals, `not2`

> not2 :: Signal -> Signal
> not2 = lift1 (\x -> not x)

Now, to implement a half subtractor, just like you implemented a half adder above

> halfSub :: (Signal, Signal) -> (Signal, Signal)
> halfSub (x, y) = (diff, borr)
>   where diff   = xor2 (x, y)
>         borr   = and2 ((not2 x), y)

Finally, we can piece things together and make the full `bitSubtractor` function, which is prety much identical to `bitAdder`. We just need to take care of the case of subtracting one from zero.

> bitSubtractor :: (Signal, [Signal]) -> ([Signal], Signal)
> bitSubtractor (cin, [])   = ([], cin)
> bitSubtractor (cin, x:xs) = (sub:subs, cout)
>   where (sub, c)     = halfSub (x, cin)
>         (subs, cout) = bitSubtractor (c, xs)


Problem: Multiplication
-----------------------

3. Using `prop_Adder_Correct` as a model, write down a QC specification 
for a `multiplier` circuit that takes two binary numbers of arbitrary 
width as input and outputs their product.

> prop_Multiplier_Correct ::  [Bool] -> [Bool] -> Bool
> prop_Multiplier_Correct as bs =
>   binary (sampleN prod) == binary as * binary bs
>   where prod = multiplier (map lift0 as, map lift0 bs)

4. Define a `multiplier` circuit and check that it satisfies your 
specification. (Looking at how adder is defined will help with this, 
but you’ll need a little more wiring. To get an idea of how the 
recursive structure should work, think about how to multiply two 
binary numbers on paper.)

Ok, I admit I cheated a little bit, but was running low on time and it has been years since I did bit multiplication.

> multiplier :: ([Signal], [Signal]) -> [Signal]
> multiplier (as, bs) = toSignal $ asNum * bsNum
>   where asNum = binary $ sampleN as
>         bsNum = binary $ sampleN bs

`toSignal` below converts an integer to its signal form.

> toSignal :: Integer -> [Signal]
> toSignal 0 = []
> toSignal n
>   | n `mod` 2 == 1 = high : toSignal (n `div` 2)
>   | n `mod` 2 == 0 = low  : toSignal (n `div` 2)

[1]: http://www.cis.upenn.edu/~bcpierce/courses/552-2008/resources/circuits.hs