module EFile12 where

import Lava
import DrawPP12
import Lava.Patterns
import Lava.Arithmetic (fullAdd,binAdder)
import Data.List



type Bit = Signal Bool
type Fan a = [a] -> [a]

type PP a = Fan a -> [a] -> [a]

type Partition = [Int]


fsT f = (f  -|- id)
snD f = (id -|-  f)

unsnoc as = (init as, last as)


f1 :: ((a,b) -> c) -> (a,b) -> (a,c)
f1 circ (a,b) = (a, circ (a,b))

fb :: ((a,b) -> c) -> (a,b) -> ((a,b),c)
fb circ ab = (ab, circ ab)

-- fullAdd1
fullAdd1 :: (Bit,(Bit,Bit)) -> (Bit,Bit)
fullAdd1 = snD gpC ->- fb carryC ->- fsT sumC

gpC:: (Bit,Bit) -> (Bit,Bit)
gpC (a,b) = (a <&> b,a <#> b)

sumC :: (Bit,(Bit,Bit)) -> Bit
sumC (cin, (_,p)) = cin <#> p

carryC :: (Bit,(Bit,Bit)) -> Bit
carryC (cin, (g,p)) = g <|> (cin <&> p)





-- Sequence of adders with the same behaviour

adder0 :: [(Bit, Bit)] -> ([Bit], Bit)
adder0 abs = row fullAdd (low,abs)

adder1 :: [(Bit, Bit)] -> ([Bit], Bit)
adder1 abs = row fullAdd1 (low,abs)

adder2 :: [(Bit, Bit)] -> ([Bit], Bit)
adder2 abs = (ss,cout)
  where
    gps       = map gpC abs
    (rs,cout) = row (fb carryC) (low,gps)
    ss        = map sumC rs

adder3 :: [(Bit, Bit)] -> ([Bit], Bit)
adder3 abs = (ss,cout)
  where
    gps       = map gpC abs
    (cs,cout) = row (f1 carryC) (low,gps)
    rs        = zip cs gps
    ss        = map sumC rs

adder4 :: [(Bit, Bit)] -> ([Bit], Bit)
adder4 abs = (ss,cout)
  where
    gps       = map gpC abs
    (cs,cout) = (row (f1 dotOp) ->- (map fst -|- fst)) ((low,high), gps)
    rs        = zip cs gps
    ss        = map sumC rs

dotOp :: ((Bit,Bit), (Bit,Bit)) -> (Bit,Bit)
dotOp ((g1,p1), (g2,p2))= (carryC (g1, (g2,p2)), p1 <&> p2)

adder5 :: [(Bit, Bit)] -> ([Bit], Bit)
adder5 abs = (ss,cout)
  where
    gps       = map gpC abs
    (cs,cout) = (ser (mkFan dotOp) ->- unsnoc ->- (map fst -|- fst) ) gps
    rs        = zip (low:cs) gps
    ss        = map sumC rs

adder6 :: [(Bit, Bit)] -> ([Bit], Bit)
adder6 abs = (ss,cout)
  where
    gps            = map gpC abs
    (cs,cout)      = (ser (mkFan dotOp) ->- unsnoc ->- (map fst -|- fst) ) gps
    ((_,p) : gps') = gps
    rs             = zip cs gps'
    ss             = p : map sumC rs

adder7 :: [(Bit, Bit)] -> ([Bit], Bit)
adder7 abs = (ss,cout)
  where
    gps            = map gpC abs
    (cs,cout)      = (skl (mkFan dotOp) ->- unsnoc ->- (map fst -|- fst) ) gps
    ((_,p) : gps') = gps
    rs             = zip cs gps'
    ss             = p : map sumC rs








mkFan :: ((a,a) -> a) -> Fan a
mkFan op (i:is) = i:[op(i,k) | k <- is]

pplus :: Fan (Signal Int)
pplus = mkFan plus



delFan ::  Fan (Signal Int)
delFan [i] = [i]
delFan is = replicate n (1 + maximum is)
  where
    n = length is

ser3 :: PP a
ser3 f [a,b,c] = [a1,b2,c2]
  where
    [a1,b1] = f [a,b]
    [b2,c2] = f [b1,c]


t3 = simulate (ser3 pplus) [1,2,3]

t3d = simulate (ser3 delFan) [0,0,0]

-- The middle prefix network from Fig. 2.

f31 :: PP a
f31 f [a,b,c] = [a1,b2,c2]
  where
    [b1,c1]    = f [b,c]
    [a1,b2,c2] = f [a,b1,c1]


f32 :: PP a
f32 f [a,b,c] = [a2,b2,c2]
  where
    [b1,c1] = f [b,c]
    [a1,c2] = f [a,c1]
    [a2,b2] = f [a1,b1]

t32d = simulate (f32 delFan) [0,0,0]

ser :: PP a
ser _  []       = []
ser _  [a]      = [a]
ser f  (a:b:bs) = a1:cs
  where
    [a1,a2] = f [a,b]
    cs      = ser f (a2:bs)




skl :: PP a
skl _ [a] = [a]
skl f as  = init los ++ ros'
  where
    (los,ros) = (skl f las, skl f ras)
    ros'      = f (last los : ros)
    (las,ras) = splitAt (cnd2 (length as)) as

cnd2 n = n - n `div` 2 -- Ceiling of n/2

tskld = simulate (skl delFan) (replicate 8 0)





-- checker function
check:: (Eq a, Num a, Enum a) => PP [a] -> a -> Bool
check func m = func (mkFan append) [[a]| a <- l] == tail (inits l)
  where l = [0..m-1]






-- Some functions that may be useful or inspiring

chop :: Int -> [a] -> [[a]]
chop n as | length as <= n  = [as]
chop n as | length as > n   = take n as : chop n (drop n as)

chop' :: Int -> [a] -> [[a]]
chop' n as | length as <= n  = [as]
chop' n as | length as > n   = take (n-1) as : chop n (drop (n-1) as)




ilvI :: Int -> ([a] -> [b]) -> [a] -> [b]
ilvI i circ = chop i ->- transpose ->- map circ ->- transpose ->- concat



toInit :: ([a] -> [a]) -> [a] -> [a]
toInit f as = f (init as) ++ [last as]

toLasts :: ([b] -> [b]) -> [[b]] -> [[b]]
toLasts f as = [is++[l] | (is,l) <- zip (map init as) (f (map last as))]

toTail :: ([b] -> [b]) -> [b] -> [b]
toTail f (a:as) = a:f as

toLast :: (t -> t) -> [t] -> [t]
toLast f (a:as) = init (a:as) ++ [f (last (a:as))]

evens :: ([a] -> [b]) -> [a] -> [b]
evens f  = chop 2 ->- map f ->- concat

odds :: ([a] -> [a]) -> [a] -> [a]
odds f (a:as) = a: evens f as












-- Ladner Fischer for use as a building block

build0 :: Partition -> PP a -> PP a
build0 ws p f
   = concat . toTail (map f) . split (shift ws) .
     concat . toInit (toLasts (p f)) .
     map (ser f) . split ws

split :: Partition -> [a] -> [[a]]
split []     [] = []
split (d:ds) as = let (las,ras) = splitAt d as in las : split ds ras

shift :: Partition -> Partition
shift (a:as) = a-1:init as ++ [last as + 1]


ladF :: Int -> PP a
ladF _ _ [a] = [a]
ladF 0 f as  = init los ++ ros'
  where
    (los,ros) = (ladF 1 f las, ladF 0 f ras)
    ros'      = f (last los : ros)
    (las,ras) = splitAt (cnd2 (length as)) as
ladF n f as  = build0 (lp (length as)) (ladF (n-1)) f as
  where lp 1 = [1,0]
        lp 2 = [2,0]
        lp n = 2 : lp (n-2)