-------------------------------------------------------------------
-- Binary Multiplier  --- Circuit Specification and Simulation
-- John O'Donnell, University of Glasgow. jtod@dcs.glasgow.ac.uk
-- Copyright (c) 1992 by John T. O'Donnell
-- version July 1992

-------------------------------------------------------------------
{- Introduction

This program demonstrates some of my work in using functional
programming for digital circuit design.  It works with the hbc
compiler, and if you comment out the definitions of 'Main' and
'main' it also works with gofer.

The program isn't polished -- I've been experimenting with several
variations, and some of the function definitions are inelegant or
inefficient.

This source file 'mult.hs' is written in Haskell and contains one
module 'Main'.  The program doesn't read any input; it just prints
a string on stdout.  To run it with hbc:

  (1) set parameters in function 'go'
      (wordsize, verbose, limit, xs)
  (2) hbc mult.hs   (produces a.out)
  (3) a.out         (no input, writes to stdout)

-}
-------------------------------------------------------------------
{- Parameters

These parameters defined in "go" control the simulation:

** wordsize
      How many bits wide the input words to be multiplied are.
      The product is 2*wordsize bits wide.
** limit
      The number of clock cycles to run the simulation.
** verbose
      If True, print lots of output.  If False, do the simulation
      but print hardly anything.
** width
      Field width in characters for integer output.
      (Used only if verbose)
** xs
      A list of pairs of natural numbers to be multiplied.
      These should be expressible in 'wordsize' bits, and the
      products should be expressible in 2*wordsize bits.

These parameter values work nicely:
    wordsize = 16	-- input size; product is twice this size
    limit = 2000	-- how many clock cycles to run
    verbose = True	-- want lots of output?
    width = 10		-- output Int field size (verbose only)
    xs =		-- pairs of integers to be multiplied
      [(2+3*i, 11+2*i) | i <- [1..]]

The verbose output contains one line per clock cycle:
    cycle.  start  a    b    ==>   ready   regA   regB   prod

-}

-------------------------------------------------------------------
{- The circuit multiplies pairs (a,b) of naturals, producing a*b

Inputs to the circuit
   start :: B
   a :: W
   b :: W

Outputs from the circuit
   ready :: B
   regA  :: W
   regB :: W
   regP :: W

Whenever 'start' is 1 the circuit saves its inputs 'a' and 'b' into
its local registers 'regA' and 'regB', and starts multiplying them
using the ordinary shift and add algorithm.  The result is
accumulated in the local register 'regP'.  While the multiplication
is in progress, 'ready' is 0 and the registers show the current
state of the circuit.  When the multiplication is finished, 'regP'
contains the product and 'ready' becomes 1.  The number of cycles
it takes to finish a multiplication depends on the values of the
inputs.

-}

-------------------------------------------------------------------

module Main where

main = putStr go

-------------------------------------------------------------------
-- Definition of the output and the simulation parameters

go =
  let
    wordsize = 16	-- input size; product is twice this size
    limit = 2000	-- how many clock cycles to run
    verbose = True	-- want lots of output?
    width = 10		-- output Int field size (verbose only)
    xs =		-- pairs of integers to be multiplied
      [(2+3*i, 11+2*i) | i <- [1..]]
  in
    "Binary multiplier circuit simulation\n"
    ++ (if verbose then traceMult width else runMult)
         wordsize limit xs

-------------------------------------------------------------------
-- Two simulation drivers

-- 'traceMult' gives full trace information.  Use it to see how
-- the multiplier works.

traceMult :: Int -> Int -> Int -> [(Int,Int)] -> String
traceMult width wordsize limit xs =
  format limit
    [fmtInt 5 [0..], fmtStr ". ",
     fmtB start, fmtW width as, fmtW width bs, fmtStr "  ==> ",
     fmtB ready, fmtW width ra, fmtW width rb, fmtW width prod,
     fmtStr "\n"]
  where (as,bs,ready,ra,rb,prod) = multsys wordsize xs
        start = ready

-- 'runMult' runs the simulation for "limit" cycles and just prints
-- the number of multiplications that were performed.  Use this
-- to measure simulation time without counting the time required
-- to format the output.  ??? This needs some work -- I'm not sure
-- that all the simulation work is actually performed!

runMult :: Int -> Int -> [(Int,Int)] -> String
runMult wordsize limit xs = show dummy ++ "\n"
  where (as,bs,ready,ra,rb,prod) = multsys wordsize xs
        dummy = (sum (take limit ready)) :: Int

-------------------------------------------------------------------
-- Interface to the multiplier

-- The multiplier circuit needs an interface that monitors the
-- 'ready' output and sets the inputs.  This interface also handles
-- conversions between integers and words.

multsys :: Int -> [(Int,Int)] -> (W,W,B,W,W,W)
multsys wordsize xs = (as,bs,ready,ra,rb,prod)
  where (ready, ra, rb,  prod) = multiplier wordsize start as bs
        start = ready
        as  = f (map fst xs)
        bs  = f (map snd xs)
        f :: [Int] -> W
        f as = ntrans wordsize (map (ibits wordsize) (g start as))
        g :: B -> [Int] -> [Int]
        g [] xs = []
        g st [] = []
        g (0:sts) xs = 0 : g sts xs
        g (1:sts) (x:xs) = x : g sts xs

-------------------------------------------------------------------
-- The multiplier circuit specification

multiplier :: Int -> B -> W -> W -> (B,W,W,W)

multiplier k start a b = (ready, regA, regB, regP)
  where
    regP = wlat (2*k) (wmux1 (2*k) start sum (rept (2*k) zerO))
    (ovfl,sum) = add (2*k) regP (wmux1 (2*k) lsbB
                   (rept (2*k) zerO) regA) zerO
    regA = wlat (2*k) (wmux1 (2*k) start (shl (2*k) regA)
                   (rept k zerO ++ a))
    regB = wlat k (wmux1 k start (shr k regB) b)
    lsbB = head (drop (k-1) regB)
    ready = or2 (regIs0 (2*k) regA) (regIs0 k regB)

-------------------------------------------------------------------
-- Comparator

regIs0 :: Int -> W -> B
regIs0 k xs = wideAnd (map inv xs)

-------------------------------------------------------------------
-- Combinational shifters

shl :: Int -> W -> W
shl k xs = drop 1 xs ++ [zerO]

shr :: Int -> W -> W
shr k xs = [zerO] ++ take (k-1) xs

-------------------------------------------------------------------
-- Adder

add :: Int -> W -> W -> B -> (B,W)
add 0 xs ys cin = (cin,[])
--should be:add (k+1) (x:xs) (y:ys) cin = (cout,s:ss)
add k (x:xs) (y:ys) cin
  | k < 0     = error "Main.add < 0"
  | otherwise = (cout,s:ss)
  where
  (cout,s) = fulladd x y c
  (c,ss) = add (k-1) xs ys cin

halfadd :: B -> B -> (B,B)
halfadd x y = (and2 x y, xor x y)

fulladd :: B -> B -> B -> (B,B)
fulladd a b c = (or2 w y, z)
  where (w,x) = halfadd a b
        (y,z) = halfadd x c

-------------------------------------------------------------------
-- Multiplexors and demultiplexors

bmux1 :: B -> B -> B -> B
bmux1 c a b = or2 (and2 (inv c) a) (and2 c b)

wmux1 :: Int -> B -> W -> W -> W
wmux1 k a = word21 k (bmux1 a)

bdemux1 :: B -> B -> (B,B)
bdemux1 c a = (and2 (inv c) a, and2 c a)

bdemux :: Int -> [B] -> B -> [B]
bdemux 0 [] x = [x]
--should be:bdemux (n+1) as x = bdemux n (tail as) p ++ bdemux n (tail as) q
bdemux n as x 
 | n < 0 = error "bdemux; n < 0"
 | otherwise = let n' = n-1 in
  bdemux n' (tail as) p ++ bdemux n' (tail as) q
  where (p,q) = bdemux1 (head as) x

-------------------------------------------------------------------
-- Registers

breg :: B -> B -> B
breg sto a = x
  where x = latch (bmux1 sto x a)

wreg :: Int -> B -> [B] -> [B]
wreg 0 sto [] = []
wreg n sto (x:xs) =
  breg sto x : wreg (n-1) sto xs

wlat :: Int -> [B] -> [B]
wlat 0 xs = []
--should be:wlat (k+1) (x:xs) = latch x : wlat k xs
wlat k (x:xs) | k < 0 = error "wlat"
	      | otherwise = latch x : wlat (k-1) xs

-------------------------------------------------------------------
-- Primitive components
                                 
latch :: B -> B
latch a = 0:a

zerO, one :: B
zerO = 0:zerO
one  = 1:one

inv = lift11 forceBit f
  where f :: Bit -> Bit
        f 0 = 1
        f 1 = 0

and2 = lift21 forceBit f
  where f :: Bit -> Bit -> Bit
        f 0 0 = 0
        f 0 1 = 0
        f 1 0 = 0
        f 1 1 = 1

nand2 = lift21 forceBit f
  where f :: Bit -> Bit -> Bit
        f 0 0 = 1
        f 0 1 = 1
        f 1 0 = 1
        f 1 1 = 0

or2 = lift21 forceBit f
  where f :: Bit -> Bit -> Bit
        f 0 0 = 0
        f 0 1 = 1
        f 1 0 = 1
        f 1 1 = 1

nor2 = lift21 forceBit f
  where f :: Bit -> Bit -> Bit
        f 0 0 = 1
        f 0 1 = 0
        f 1 0 = 0
        f 1 1 = 0

or3 = lift31 forceBit f
  where f :: Bit -> Bit -> Bit -> Bit
        f 0 0 0 = 0
        f 0 0 1 = 1
        f 0 1 0 = 1
        f 0 1 1 = 1
        f 1 0 0 = 1
        f 1 0 1 = 1
        f 1 1 0 = 1
        f 1 1 1 = 1

xor = lift21 forceBit f
  where f :: Bit -> Bit -> Bit
        f 0 0 = 0
        f 0 1 = 1
        f 1 0 = 1
        f 1 1 = 0

-------------------------------------------------------------------
-- Wide gates

wideGate f [x] = x
wideGate f xs =
  f (wideGate f (take i xs))
    (wideGate f (drop i xs))
  where i = length xs `div` 2

wideAnd xs  = wideGate and2 xs
wideNand xs = wideGate nand2 xs
wideOr xs   = wideGate or2 xs
wideNor xs  = wideGate nor2 xs

-------------------------------------------------------------------
-- Auxiliary definitions

type Bit = Int
type B = [Bit]
type W = [B]

forceBit :: Bit->Bool
forceBit x = (x==0)

headstrict :: (a->Bool) -> [a] -> [a]
headstrict force [] = []
headstrict force xs = if force (head xs) then xs else xs

pairstrict :: (a->Bool) -> (b->Bool) -> ([a],[b]) -> ([a],[b])
pairstrict force1 force2 p =
  if force1 (head x)
     then if force2 (head y) then p else p
     else if force2 (head y) then p else p
  where (x,y) = p

lift11 force f [] = []
lift11 force f (x:xs) = headstrict force (f x : lift11 force f xs)

{-
lift21 force f [] zs = []
lift21 force f ys [] = []
lift21 force f (y:ys) (z:zs) =
  headstrict force (f y z : lift21 force f ys zs)
-}

--lift21 force f [] zs = []
--lift21 force f ys [] = []
lift21 force f (y:ys) (z:zs) =
   (f y z : lift21 force f ys zs) -- ??? space leak here?

lift31 force f [] ys zs = []
lift31 force f xs [] zs = []
lift31 force f xs ys [] = []
lift31 force f (x:xs) (y:ys) (z:zs) =
  headstrict force (f x y z : lift31 force f xs ys zs)

lift41 force f [] xs ys zs = []
lift41 force f ws [] ys zs = []
lift41 force f ws xs [] zs = []
lift41 force f ws xs ys [] = []
lift41 force f (w:ws) (x:xs) (y:ys) (z:zs) =
  headstrict force (f w x y z : lift41 force f ws xs ys zs)

lift22 force1 force2 f [] ys = ([],[])
lift22 force1 force2 f xs [] = ([],[])
lift22 force1 force2 f (x:xs) (y:ys) =
  pairstrict force1 force2 (a:as, b:bs)
  where (a,b) = f x y
        (as,bs) = lift22 force1 force2 f xs ys

-------------------------------------------------------------------
-- Words

word11 :: Int -> (a->b) -> [a] -> [b]
word11 0 f as = []
word11 k f as = f (head as) : word11 (k-1) f (tail as)

word21 :: Int -> (a->b->c) -> [a] -> [b] -> [c]
word21 0 f as bs = []
word21 k f as bs =
  f (head as) (head bs) : word21 (k-1) f (tail as) (tail bs)

word31 :: Int -> (a->b->c->d) -> [a] -> [b] -> [c] -> [d]
word31 0 f as bs cs = []
word31 k f as bs cs =
  f (head as) (head bs) (head cs) :
    word31 (k-1) f (tail as) (tail bs) (tail cs)

word12 :: Int -> (a->(b,c)) -> [a] -> ([b],[c])
word12 0 f as = ([],[])
word12 k f as = (b:bs,c:cs)
  where (b,c) = f (head as)
        (bs,cs) = word12 (k-1) f (tail as)

word22 :: Int -> (a->b->(c,d)) -> [a] -> [b] -> ([c],[d])
word22 0 f as bs = ([],[])
word22 k f as bs = (c:cs,d:ds)
  where (c,d) = f (head as) (head bs)
        (cs,ds) = word22 (k-1) f (tail as) (tail bs)

-------------------------------------------------------------------
-- Conversions

shoInt :: Int -> String
shoInt n = show n

trans :: [[a]] -> [[a]]
trans xs =
  if or (map null xs)
    then []
    else map head xs : trans (map tail xs)

ntrans 0 xs = []
ntrans i xs = map head xs : ntrans (i-1) (map tail xs)

dec :: Int -> Int -> String
dec k n =
  if i<k then (rept (k-i) ' ') ++ xs else xs
  where xs = show n
        i = length xs

ibits :: Int -> Int -> [Int]
ibits n i = reverse (f_ibits n i)
  where f_ibits 0 i = []
        f_ibits n i = i `mod` 2 : f_ibits (n-1) (i `div` 2)

{- bitsi converts a binary number represented by a list of bits
into an integer. -}

bitsi :: [Int] -> Int
bitsi = f_bitsi 0
  where f_bitsi i [] = i
        f_bitsi i (b:bs) = f_bitsi (2*i+b) bs

-- These functions lift the integer--bits conversions to streams.

intrep :: [B] -> [Int]
intrep bs = map bitsi (trans bs)

bitrep :: Int -> [Int] -> [B]
bitrep n = ntrans n . map (ibits n)

-------------------------------------------------------------------
-- Formatting

rept :: Int -> a -> [a]
rept 0 x = []
rept i x = x : rept (i-1) x

mksepline c = "\n" ++ rept 79 c ++ "\n"
sepline = mksepline '-'
bigsepline = mksepline '='
   
format :: Int -> [[[a]]] -> [a]
format limit = concat . take limit . map concat . trans

--fmtW :: Int -> W ->
fmtW i xs = fmtDec i (intrep xs)

-- fmtDec  width of field
fmtDec :: Int -> [Int] -> [String]
fmtDec w = map (dec w)

fmtB :: B -> [String]
fmtB = map (dec 1)

fmtInt :: Int -> [Int] -> [String]
fmtInt i = map (dec i)

fmtFld :: (Int->Bit->String) -> Int -> [B] -> [String]
fmtFld f i xs = map (f i) (intrep xs)

fmtList :: (a->String) -> [[a]] -> [String]
fmtList f xs = map (g . concat . map f) xs
  where g cs = cs ++ "  "

fmtStr :: String -> [String]
fmtStr s = s : fmtStr s

{- when takes a ready signal xs and an arbitrary signal ys,
returning the value on the ys signal at the first cycle that xs is
1. -}

when :: B -> W -> [Int]
when (0:xs) w = when xs (map tail w)
when (1:xs) w = map head w

-------------------------------------------------------------------