Reversible two-input demultiplexer. The target is to design a reversible circuit, using NOT, CNOT, Toffoli, and Fredkin gates, which acts on the two arbitrary inputs a,b, and the two fixed inputs c=0, d=0, to produce four bits a′, b′, c′, d′ of output, where only the nth output is 1 (the others are all 0), and n=2b+a.

reversible.hs

{-# LANGUAGE BinaryLiterals #-}

import Data.Bits (Bits, xor, bit, testBit, complementBit, setBit, clearBit, (.&.), shiftR)
import Data.Array (Array, listArray, (//), (!))

initialState = [0b0000, 0b0001, 0b0010, 0b0011]
targetState = [0b0001, 0b0010, 0b0100, 0b1000]

encodeState = sum . zipWith (*) [4096, 256, 16, 1]

decodeState x = map (.&. 0b1111) [x `shiftR` 12, x `shiftR` 8, x `shiftR` 4, x]

choose :: Eq a => Int -> [a] -> [[a]]
choose 1 xs = map (: []) xs
choose n xs = do
    x <- xs
    ys <- choose (n-1) (filter (/= x) xs)
    return (x:ys)


swapBit :: Bits a => a -> Int -> Int -> a
swapBit m x y = let vx = testBit m x
                    vy = testBit m y
                    m' = if vx then setBit m y else clearBit m y
                 in if vy then setBit m' x else clearBit m' x

dec2 x = let vs = choose 2 [0..3] !! x in (vs !! 0, vs !! 1)
dec3 x = let vs = choose 3 [0..3] !! x in (vs !! 0, vs !! 1, vs !! 2)

transTable :: Array (Int, Int) Int
transTable = listArray ((0, 0), (63, 15)) $ concatMap buildTable [0..63]
    where
        buildTable x = map (decode x) [0..15]
        decode x | x < 4  = -- not
                    xor $ bit x
                 | x < 16 = -- cnot
                    let (a, b) = dec2 (x - 4)
                     in \m -> if testBit m a then complementBit m b else m
                 | x < 40 = -- toffoli
                    let (a, b, c) = dec3 (x - 16)
                     in \m -> if testBit m a && testBit m b then complementBit m c else m
                 | otherwise =  -- fredkin
                    let (a, b, c) = dec3 (x - 40)
                     in \m -> if testBit m a
                                then swapBit m b c
                                else m

stateTable = listArray ((0, 0), (6, 2 ^ 16 - 1)) (repeat (-1, -1))

initialTable = stateTable // [((0, encodeState initialState), (0, -1))]

updataState :: Int -> Int -> Int
updataState x g = encodeState $ map (\s -> transTable ! (g, s)) (decodeState x)

findPath :: Array (Int, Int) (Int, Int) -> Int -> Int -> [Int] -> [Int]
findPath t 0 target acc = acc
findPath t s target acc = findPath t (s-1) target' (gate:acc)
    where
        (target', gate) = t ! (s, target)

solve :: Array (Int, Int) (Int, Int) -> Int -> [Int]
solve t s = if fst (t ! (s, target)) >= 0
                then findPath t s target []
                else solve (t // updated) (s+1)
    where
        target = encodeState targetState
        updated = [((s+1, updataState x g), (x, g)) | x <- [0..2^16-1], fst (t ! (s, x)) >= 0, g <- [0..63]]

solution = solve initialTable 0