path: root/testsuite/tests/concurrent/prog001/Arithmetic.hs

module Arithmetic where

import Control.Concurrent
import Control.Concurrent.MVar
import System.IO.Unsafe
import Utilities
import Converter
import Stream
import Data.Ratio
import Trit


-- Negate a stream of Gray code
negateGray :: Gray -> Gray
negateGray = fl


-- Multiply a Gray code stream by 2
-- The stream must represent a real number in (-1/2, 1/2) only
mul2 :: Gray -> Gray
mul2 (x:1:xs) = (x:fl xs)


-- Division by 2, the result is to be in (-1/2, 1/2)
div2 :: Gray -> Gray
div2 (x:xs) = x:1:(fl xs)


-- Addition by 1, the input must be in (-1,0)
plusOne :: Gray -> Gray
plusOne (0:xs) = 1:fl xs



-- Subtraction by 1, the input must be in (0,1)
minusOne :: Gray -> Gray
minusOne (1:xs) = 0:fl xs




threadTesting :: Gray -> Gray -> IO Int
threadTesting xs ys = do
                    m <- newEmptyMVar
                    c1 <- forkIO (t1 m xs ys)
                    c2 <- forkIO (t2 m xs ys)
                    c3 <- forkIO (t3 m xs ys)
                    c4 <- forkIO (t4 m xs ys)
                    c5 <- forkIO (t5 m xs ys)
                    c6 <- forkIO (t6 m xs ys)
                    c <- takeMVar m
                    killThread c1
                    killThread c2
                    killThread c3
                    killThread c4
                    killThread c5
                    killThread c6
                    return c




addition :: Gray -> Gray -> IO Gray
addition xs ys = do
                                        c <- threadTesting xs ys
                                        case c of
                                           1 -> do
                                                   let tx = tail xs
                                                   let ty = tail ys
                                                   t <- unsafeInterleaveIO (addition  tx ty)
                                                   return (0:t)
                                           2 ->  do
                                                   let tx = tail xs
                                                   let ty = tail ys
                                                   t <- unsafeInterleaveIO (addition tx ty)
                                                   return (1:t)
                                           3 ->  do
                                                   let tx = tail xs
                                                   let ty = tail ys
                                                   cs <- unsafeInterleaveIO (addition tx (fl ty))
                                                   let c1 = cs !! 0
                                                   let c2 = tail cs
                                                   return (c1:1:fl c2)
                                           4 ->  do
                                                   let tx = tail xs
                                                   let ty = tail ys
                                                   (cs) <- unsafeInterleaveIO (addition (fl tx) ty)
                                                   let c1 = cs !! 0
                                                   let c2 = tail cs
                                                   return (c1:1:(fl c2))
                                           5 ->  do
                                                   let x1 = xs!!0
                                                   let y1 = ys!!0
                                                   let tx = (drop 2) xs
                                                   let ty = (drop 2) ys
                                                   cs <- unsafeInterleaveIO (addition (x1:(fl tx)) (y1:(fl ty)))
                                                   let c1 = cs !! 0
                                                   let c2 = tail cs
                                                   return (c1:(1:(fl c2)))
                                           6 ->  do
                                                   let x1 = xs !! 0
                                                   let tx = drop 3 xs
                                                   let ty = drop 2 ys
                                                   t <- unsafeInterleaveIO (addition (x1:1:tx) (1:fl ty))
                                                   return (0:t)
                                           7 ->  do
                                                   let x1 = xs !! 0
                                                   let tx = drop 3 xs
                                                   let ty = drop 2 ys
                                                   t <- unsafeInterleaveIO (addition (fl (x1:1:tx)) (1:(fl ty)))
                                                   return (1:t)
                                           8 ->  do
                                                   let x1 = xs !! 0
                                                   let y2 = ys !! 1
                                                   let tx = drop 3 xs
                                                   let ty = drop 3 ys
                                                   t <- unsafeInterleaveIO (addition (fl (x1:fl tx)) (fl (y2:fl ty)))
                                                   return (0:1:t)
                                           9 ->  do
                                                   let x1 = xs !! 0
                                                   let y2 = ys !! 1
                                                   let tx = drop 3 xs
                                                   let ty = drop 3 ys
                                                   t <- unsafeInterleaveIO (addition (x1:fl tx) (fl (y2:fl ty)))
                                                   return (1:1:t)
                                           10 ->  do
                                                   let y1 = ys !! 0
                                                   let ty = drop 3 ys
                                                   let tx = drop 2 xs
                                                   t <- unsafeInterleaveIO (addition (1:fl tx) (y1:1:ty))
                                                   return (0:t)
                                           11 ->  do
                                                   let y1 = ys !! 0
                                                   let ty = drop 3 ys
                                                   let tx = drop 2 xs
                                                   t <- unsafeInterleaveIO (addition (1:fl tx) (fl (y1:1:ty)))
                                                   return (1:t)
                                           12 ->  do
                                                   let y1 = ys !! 0
                                                   let x2 = xs !! 1
                                                   let tx = drop 3 xs
                                                   let ty = drop 3 ys
                                                   t <- unsafeInterleaveIO (addition (fl (x2:fl tx)) (fl (y1:fl ty)))
                                                   return (0:1:t)
                                           13 ->  do
                                                   let y1 = ys !! 0
                                                   let x2 = xs !! 1
                                                   let tx = drop 3 xs
                                                   let ty = drop 3 ys
                                                   t <- unsafeInterleaveIO (addition (fl (x2:fl tx)) (y1:fl ty))
                                                   return (1:1:t)













-- Compute (a-b)/2
substraction :: Gray -> Gray -> IO Gray
substraction xs ys = addition xs (negateGray ys)





t1 :: MVar Int -> Stream -> Stream -> IO()
t1 m (0:as) (0:bs) = putMVar m 1
t1 m (1:as) (1:bs) = putMVar m 2
t1 m (0:as) (1:bs) = putMVar m 3
t1 m (1:as) (0:bs) = putMVar m 4


t2 :: MVar Int -> Stream -> Stream -> IO()
t2 m (a:1:x) (b:1:y) = putMVar m 5
t2 m x y = yield


t3 m (a:1:0:x) (0:0:y) = putMVar m 6
t3 m (a:1:0:x) (1:0:y) = putMVar m 7
t3 m x y = yield


t4 m (a:1:0:x) (0:b:1:y) = putMVar m 8
t4 m (a:1:0:x) (1:b:1:y) = putMVar m 9
t4 m x y = yield


t5 m (0:0:x) (b:1:0:y) = putMVar m 10
t5 m (1:0:x) (b:1:0:y) = putMVar m 11
t5 m x y = yield


t6 m (0:a:1:x) (b:1:0:y) = putMVar m 12
t6 m (1:a:1:x) (b:1:0:y) = putMVar m 13
t6 m x y = yield





multiplyIO :: Gray -> Gray -> IO Gray
multiplyIO xs ys = do
                    s1 <- unsafeInterleaveIO (grayToSignIO xs)
                    s2 <- unsafeInterleaveIO (grayToSignIO ys)
                    let s = Trit.multiply s1 s2
                    let g = signToGray s
                    return g



start :: IO()
start = do
           c <- unsafeInterleaveIO(multiplyIO z1 z1)
           putStrLn (show c)


startA :: IO()
startA = do
           c <- unsafeInterleaveIO(addition (1:1:z0) (1:1:z0))
           putStrLn (show (take 30 c))

z0 = (0:z0)
z1 = (1:z1)

zl = 0:loop:z0

loop = loop
loop01 = 0:1:loop01