Commit 9ae84316 authored by simonmar's avatar simonmar
Browse files

[project @ 2005-09-13 10:06:59 by simonmar]

add test for bug #1285326
parent 0a4224d6
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
-- Substraction 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
module Converter (rationalToGray, grayToSignIO, signToGray, Gray, startF, startC) where
import Stream
import Data.Ratio
import Control.Concurrent
import Control.Concurrent.MVar
import System.IO.Unsafe
type Gray = [Integer]
type State = (Integer, Integer)
-- Convert a rational number (in (-1,1)) to its Gray representation
rationalToGray :: Rational -> Gray
rationalToGray x
|x<0 = f (negate' (rationalToStream (-x))) (0,0)
|otherwise = f (rationalToStream x) (0,0)
-- Function to implement the two heads Turing machine that convert a
-- signed-digit stream to the corresponding Gray-code representation
f :: Stream -> State -> Stream
f (x:xs) (0,0)
|x==(-1) = 0:f xs (0,0)
|x==0 = c:1:ds
|x==1 = 1:f xs (1,0)
where c:ds = f xs (0,1)
f (x:xs) (0,1)
|x==(-1) = 0:f xs (1,0)
|x==0 = c:0:ds
|x==1 = 1:f xs (0,0)
where c:ds = f xs (0,1)
f (x:xs) (1,0)
|x==(-1) = 1:f xs (0,0)
|x==0 = c:1:ds
|x==1 = 0:f xs (1,0)
where c:ds = f xs (1,1)
f (x:xs) (1,1)
|x==(-1) = 1:f xs (1,0)
|x==0 = c:0:ds
|x==1 = 0:f xs (0,0)
where c:ds = f xs (1,1)
-- Anotherway to convert from a rational to Gray code representation
-- Behave exactly the same like above
rationalToGray' :: Rational -> Gray
rationalToGray' x
|x<0 = signToGray (negate' (rationalToStream (-x)))
|otherwise = signToGray (rationalToStream x)
-- Function to convert a signed-digit stream to Gray representation
-- Is much shorter than above
signToGray :: Stream -> Stream
signToGray (1:xs) = 1:f'(signToGray xs)
signToGray ((-1):xs) = 0:signToGray xs
signToGray (0:xs) = c:1:(f' ds)
where c:ds = signToGray xs
-- Convert a Gray-code stream to the corresponding signed-digit representation
-- Make use of threads
grayToSignIO :: Stream -> IO Stream
grayToSignIO (x1:x2:xs) = do
c <- threadTesting(x1:x2:xs)
if (c==1)
then (do co <- unsafeInterleaveIO (grayToSignIO (f'(x2:xs)))
return (1:co))
else if (c==2)
then (do co <- unsafeInterleaveIO (grayToSignIO (x2:xs))
return ((-1):co))
else (do co <- unsafeInterleaveIO (grayToSignIO (x1:f' xs))
return (0:co))
-- Flip the first bit of an infinite stream
f' (x:xs) = (f'' x):xs
where f'' 1 = 0
f'' 0 = 1
-- Launch two threads which run concurrently, test for the first digit of the stream (1, 0 or bottom)
-- As soon as one thread terminate, grab that result and proceed
threadTesting :: Stream -> IO Int
threadTesting xs = do m <- newEmptyMVar
c1 <- forkIO (f1 m xs)
c2 <- forkIO (f2 m xs)
c <- takeMVar m
killThread c1
killThread c2
return c
-- Test case 1, when the first bit is either 1 or 0.
-- In case of bottom, f1 will never terminate, then f2 will definitely terminate
f1 :: MVar Int -> Stream -> IO()
f1 m (0:xs) = putMVar m 2
f1 m (1:xs) = putMVar m 1
-- Test case 2, when the first bit is completely ignored, esp in case it was a bottom
-- If the second bit is 1, then we can output, don't care value of the first bit
-- If the second bit is 0, then loop forever, give chances to f1 to terminate
f2 :: MVar Int -> Stream -> IO()
f2 m (c1:c2:xs)
|c2==1 = putMVar m 3
|otherwise = yield
-- Testing
startC :: IO()
startC = do
c<- unsafeInterleaveIO (grayToSignIO (1:1:z0))
putStrLn (show (take 100 c))
startF = signToGray ((-1):1:z0)
z0 = 0:z0
loop' = loop'
z1' = (1:z1')
TOP=../../../..
include $(TOP)/mk/boilerplate.mk
include $(TOP)/mk/test.mk
module Main where
import Arithmetic
import Trit
import Stream
import Converter
import Control.Concurrent
import Control.Concurrent.MVar
import System.IO.Unsafe
import Data.Ratio
import Utilities
import Thread
main = startM1
startM1 :: IO()
startM1 = do
c <- unsafeInterleaveIO (mult (rationalToGray (1%3)) (rationalToGray (0%1)))
putStrLn (show (take 100 (drop 1 c)))
mult :: Gray -> Gray -> IO Gray
mult xs ys = do
c <- threadTesting1 xs ys
case c of
101 -> do
--putStrLn ("In case 101")
let tx = drop 2 xs
let ty = drop 2 ys
t1 <- unsafeInterleaveIO (addition tx ty)
t2 <- unsafeInterleaveIO (addition (fl t1) (1:t1))
t3 <- unsafeInterleaveIO (mult tx ty)
c' <- unsafeInterleaveIO (addition t2 (1:0:0:(fl t3)))
return c'
102 -> do
--putStrLn ("In case 102")
let tx = drop 2 xs
let ty = drop 2 ys
t1 <- unsafeInterleaveIO (addition (fl tx) ty)
t2 <- unsafeInterleaveIO (addition tx ty)
t0 <- unsafeInterleaveIO (addition t1 (1:fl t2))
t3 <- unsafeInterleaveIO (mult tx ty)
c' <- unsafeInterleaveIO (addition t0 (1:1:0:fl t3))
return c'
103 -> do
--putStrLn ("In case 103")
let tx = drop 2 xs
let ty = drop 2 ys
t <- unsafeInterleaveIO (mult (0:0:tx) (0:0:ty))
return (fl t)
104 -> do
--putStrLn ("In case 104")
let tx = drop 2 xs
let ty = drop 2 ys
t <- unsafeInterleaveIO (mult (0:0:tx) (0:1:ty))
return (fl t)
201 -> do
c' <- unsafeInterleaveIO (mult ys xs)
return c'
202 -> do
--putStrLn ("In case 202")
let tx = drop 2 xs
let ty = drop 2 ys
t1 <- unsafeInterleaveIO (addition tx ty)
t2 <- unsafeInterleaveIO (addition t1 (0:fl t1))
t3 <- unsafeInterleaveIO (mult tx ty)
c' <- unsafeInterleaveIO (addition t2 (1:1:1:fl t3))
return c'
203 -> do
--putStrLn ("In case 203")
let tx = drop 2 xs
let ty = drop 2 ys
t <- unsafeInterleaveIO (mult (0:1:tx) (0:0:ty))
return (fl t)
204 -> do
--putStrLn ("In case 204")
let tx = drop 2 xs
let ty = drop 2 ys
t <- unsafeInterleaveIO (mult (0:1:tx) (0:1:ty))
return (fl t)
30 -> do
--putStrLn ("In case 30")
let y1 = ys !! 0
let tx = drop 2 xs
let ty = drop 3 ys
t1 <- unsafeInterleaveIO (addition ((f0' y1):1:ty) ((f0' y1):1:0:ty))
t0 <- unsafeInterleaveIO (mult tx (y1: fl ty))
let c4 = head t0
let d4 = fl (tail t0)
c' <- unsafeInterleaveIO (addition t1 (c4:1:0:0:d4))
return c'
31 -> do
--putStrLn ("In case 31")
let tx = drop 2 xs
c' <- unsafeInterleaveIO (mult (0:0:tx) ys)
return (fl c')
40 -> do
--putStrLn ("In case 40")
let tx = drop 2 xs
let y2 = ys !! 1
let ty = drop 3 ys
t1 <- unsafeInterleaveIO (addition (y2:fl ty) tx)
t2 <- unsafeInterleaveIO (addition (fl t1) (1:y2:1:ty))
t0 <- unsafeInterleaveIO (mult tx (y2:fl ty))
let c2 = f0' (head t0)
let d2 = fl (tail t0)
c' <- unsafeInterleaveIO (addition t2 (1:c2:1:0:d2))
return c'
41 -> do
--putStrLn ("In case 41")
let tx = drop 2 xs
let y2 = ys !! 1
let ty = drop 3 ys
c' <- unsafeInterleaveIO (mult (0:0:tx) (0:y2:1:ty))
return (fl c')
50 -> do
--putStrLn ("In case 50")
let tx = drop 2 xs
let y2 = ys !! 1
let ty = drop 3 ys
t1 <- unsafeInterleaveIO (addition tx (fl (y2:fl ty)))
t2 <- unsafeInterleaveIO (addition t1 (0:y2:1:ty))
t0 <- unsafeInterleaveIO (mult (fl tx) (y2:fl ty))
let c1 = f0' (head t0)
let d1 = fl (tail t0)
c' <- unsafeInterleaveIO (addition t2 (1:c1:1:0:d1))
return c'
51 -> do
--putStrLn ("In case 51")
let tx = drop 2 xs
let y2 = ys !! 1
let ty = drop 3 ys
c' <- unsafeInterleaveIO (mult (0:1:tx) (0:y2:1:ty))
return (fl c')
60 -> do
--putStrLn ("In case 60")
let tx = drop 2 xs
let y1 = ys !! 0
let ty = drop 3 ys
t1 <- unsafeInterleaveIO (addition ((f0' y1):1:ty) (y1:1:0:ty))
t0 <- unsafeInterleaveIO (mult (fl tx) (y1:fl ty))
let c1 = head t0
let d1 = fl (tail t0)
c' <- unsafeInterleaveIO (addition t1 (c1:1:0:0:d1))
return c'
61 -> do
--putStrLn ("In case 61")
let tx = drop 2 xs
let y1 = ys !! 0
let ty = drop 3 ys
c' <- unsafeInterleaveIO (mult (0:1:tx) (y1:1:0:ty))
return (fl c')
70 -> do
--putStrLn ("In case 70")
c' <- unsafeInterleaveIO (mult ys xs)
return c'
80 -> do
--putStrLn ("In case 80")
let x2 = xs !! 1
let y2 = ys !! 1
let tx = drop 3 xs
let ty = drop 3 ys
t1 <- unsafeInterleaveIO (addition (x2:fl tx) (y2:fl ty))
t0 <- unsafeInterleaveIO (mult (x2:fl tx) (y2:fl ty))
let c1 = head (fl t1)
let d1 = tail (fl t1)
let c2 = f0' (head t0)
let d2 = fl (tail t0)
c' <- unsafeInterleaveIO (addition (c1:1:(fl d1)) (1:c2:1:0:d2))
return c'
81 -> do
--putStrLn ("In case 81")
let x2 = xs !! 1
let y2 = ys !! 1
let tx = drop 3 xs
let ty = drop 3 ys
c' <- unsafeInterleaveIO (mult (0:x2:1:tx) (0:y2:1:ty))
return (fl c')
90 -> do