108 lines
6.0 KiB
Haskell
108 lines
6.0 KiB
Haskell
|
{-# LANGUAGE ForeignFunctionInterface #-}
|
||
|
|
{-# OPTIONS -lcircsim -L. #-}
|
||
|
|
|
||
|
|
-- gcc -fPIC -shared -o libcircsim.so circsim.c
|
||
|
|
-- ghci CircuitC.hs -lcircsim -L.
|
||
|
|
|
||
|
|
module CircuitC (execCircuit, execCircuit2, checkCircuit, checkCircuits) where
|
||
|
|
|
||
|
|
import Foreign.C.Types
|
||
|
|
import Foreign.Storable
|
||
|
|
import Foreign.Ptr
|
||
|
|
import Foreign.Marshal.Array
|
||
|
|
import Foreign.Marshal.Alloc
|
||
|
|
import System.IO.Unsafe
|
||
|
|
|
||
|
|
import Data.List
|
||
|
|
import Data.Maybe
|
||
|
|
|
||
|
|
import Encoding
|
||
|
|
import CircuitBase
|
||
|
|
|
||
|
|
foreign import ccall unsafe "circsim.h circsim"
|
||
|
|
imp_circsim :: CInt -> Ptr CInt -> Ptr CInt -> CInt -> Ptr CInt -> IO ()
|
||
|
|
-- (int gates, int *gatepins, int *states, int streamlen, int *stream)
|
||
|
|
foreign import ccall unsafe "circsim.h findcirc"
|
||
|
|
imp_findcirc :: CInt -> Ptr CInt -> CInt -> Ptr CInt -> Ptr CInt -> IO CInt
|
||
|
|
-- (int gates, int *gatepins, int *states, int streamlen, int *stream, int *output)
|
||
|
|
|
||
|
|
normlists a b = unzip $ zip a b
|
||
|
|
|
||
|
|
execCircuit :: Stream s => Circuit -> s
|
||
|
|
execCircuit c = execCircuit2 c (streamread server_input ++ repeat T0)
|
||
|
|
execCircuit2 :: (Stream s1, Stream s2) => Circuit -> s1 -> s2
|
||
|
|
execCircuit2 c input = streamwrite $ execCircuit3 c $ streamread input
|
||
|
|
|
||
|
|
execCircuit3 c input = map toTrit $ snd $ circsim n (take (length n) $ repeat 0) i where
|
||
|
|
n = circ_to_native c
|
||
|
|
i = map fromTrit input :: [Int]
|
||
|
|
|
||
|
|
checkCircuit :: (Stream s1, Stream s2) => Circuit -> s1 -> s2 -> Bool
|
||
|
|
checkCircuit c input output = findcirc n i o where
|
||
|
|
n = circ_to_native c
|
||
|
|
(i, o) = normlists (map fromTrit $ streamread input) (map fromTrit $ streamread output)
|
||
|
|
|
||
|
|
checkCircuits :: (Stream s1, Stream s2) => s1 -> s2 -> [Circuit] -> [Circuit]
|
||
|
|
checkCircuits input output circs = map native_to_circ $ maybeToList $ findcircs (map circ_to_native circs) i o where
|
||
|
|
(i, o) = normlists (map fromTrit $ streamread input) (map fromTrit $ streamread output)
|
||
|
|
|
||
|
|
circsim :: [Int] -> [Int] -> [Int] -> ([Int], [Int])
|
||
|
|
circsim gatepins state input = unsafePerformIO $ do
|
||
|
|
let gates = length gatepins `div` 2
|
||
|
|
let slen = length input
|
||
|
|
pins <- newArray $ map fromIntegral gatepins :: IO (Ptr CInt)
|
||
|
|
states <- newArray $ map fromIntegral state :: IO (Ptr CInt)
|
||
|
|
sin <- newArray $ map fromIntegral input :: IO (Ptr CInt)
|
||
|
|
imp_circsim (fromIntegral gates) pins states (fromIntegral slen) sin
|
||
|
|
ostate <- peekArray (length state) states
|
||
|
|
output <- peekArray slen sin
|
||
|
|
free states
|
||
|
|
free sin
|
||
|
|
free pins
|
||
|
|
return (map fromIntegral ostate, map fromIntegral output)
|
||
|
|
|
||
|
|
-- input and output must have the same length
|
||
|
|
findcircs :: [[Int]] -> [Int] -> [Int] -> Maybe [Int]
|
||
|
|
findcircs circs input output = unsafePerformIO $ do
|
||
|
|
let slen = length input
|
||
|
|
sin <- newArray $ map fromIntegral input :: IO (Ptr CInt)
|
||
|
|
sout <- newArray $ map fromIntegral output :: IO (Ptr CInt)
|
||
|
|
res <- findfirstcirc slen sin sout circs
|
||
|
|
free sin
|
||
|
|
free sout
|
||
|
|
return res where
|
||
|
|
findfirstcirc slen sin sout [] = return Nothing
|
||
|
|
findfirstcirc slen sin sout (gatepins:circs) = do
|
||
|
|
let gates = length gatepins `div` 2
|
||
|
|
pins <- newArray $ map fromIntegral gatepins :: IO (Ptr CInt)
|
||
|
|
res <- imp_findcirc (fromIntegral gates) pins (fromIntegral slen) sin sout
|
||
|
|
free pins
|
||
|
|
if (res /= 0) then return (Just gatepins) else findfirstcirc slen sin sout circs
|
||
|
|
|
||
|
|
|
||
|
|
-- input and output must have the same length
|
||
|
|
findcirc :: [Int] -> [Int] -> [Int] -> Bool
|
||
|
|
findcirc gatepins input output = unsafePerformIO $ do
|
||
|
|
let gates = length gatepins `div` 2
|
||
|
|
let slen = length input
|
||
|
|
pins <- newArray $ map fromIntegral gatepins :: IO (Ptr CInt)
|
||
|
|
sin <- newArray $ map fromIntegral input :: IO (Ptr CInt)
|
||
|
|
sout <- newArray $ map fromIntegral output :: IO (Ptr CInt)
|
||
|
|
res <- imp_findcirc (fromIntegral gates) pins (fromIntegral slen) sin sout
|
||
|
|
free sin
|
||
|
|
free sout
|
||
|
|
free pins
|
||
|
|
return $ res /= 0
|
||
|
|
|
||
|
|
brutecircs :: Int -> [Int] -> Maybe Circuit
|
||
|
|
brutecircs gates output = case findcircs (permutations [0..2*gates]) (map fromTrit $ streamread server_input) output of
|
||
|
|
Nothing -> Nothing
|
||
|
|
Just p -> Just $ circ_from_perm $ map (\x -> x-1) p
|
||
|
|
|
||
|
|
|
||
|
|
circ_to_native :: Circuit -> [Int]
|
||
|
|
circ_to_native (Circuit o p) = (map (1+) (o:p))
|
||
|
|
|
||
|
|
native_to_circ :: [Int] -> Circuit
|
||
|
|
native_to_circ n = let (o:p) = map (\x -> x-1) n in Circuit o p
|