import Data.List import Data.Bits import Data.Word import Data.Array import Random import System.Environment choose 0 _ = [[]] choose _ [] = [ ] choose k (x:xs) = choose k xs ++ map (x:) (choose (k-1) xs) r = 6 simpleComplement a = [1..(2*r)] \\ a simpleOptions = [a | a <- choose r [1..(2*r-1)], not \$ a `simpleLeftOf` (simpleComplement a)] simpleLeftOf xs ys = all id \$ zipWith (<=) xs ys simpleCount [] = 1 simpleCount (a:as) = simpleCount take + simpleCount leave where -- take a -- all pairs with b < a or b^c < a are forced -- second case never happens as b^c has 2r but a doesn't take = [b | b <- as, not \$ b `simpleLeftOf` a] -- leave a, and so take a^c -- all pairs with b < a^c or b^c < a^c (equivalently, a < b) are forced c = simpleComplement a leave = [b | b <- as, not (b `simpleLeftOf` c || a `simpleLeftOf` b)] interleave [] [] = [] interleave (x:xs) (y:ys) = x : y : interleave xs ys mask :: Word64 mask = 2^(r*(r+1))-1 odds :: Word64 odds = foldr (flip setBit) 0 [1,3..63] evens :: Word64 evens = foldr (flip setBit) 0 [0,2..62] initialState = odds .&. (complement mask) grid = b where -- array mapping grid squares to bit vectors -- (i,j) and (j,i) are stored in consecutive positions that are fast to swap -- unused bits are set if and only if odd, so that they are invariant under swapping -- odd and even bits then complementing -- diagonal entries use two bits so they are invariant under swapping odd and even bits lowerHalf = [(i,j) | i <- [0..(r-1)], j <- [0..i]] upperHalf = [(j,i) | i <- [0..(r-1)], j <- [0..i]] bits = map bit [0..] :: [Word64] s = zip (interleave lowerHalf upperHalf) bits a = accumArray (.|.) 0 ((0,0), (r-1,r-1)) s t = [((i,j), foldr (.|.) initialState [a!(i,k) | k <- [0..j-1]]) | i <- [0..(r-1)], j <- [0..r]] b = array ((0,0), (r-1,r)) t toUnary x = foldr (.|.) 0 [grid ! y | y <- zip [0..] (zipWith (-) x [1..])] fastLeftOf a b = (a .&. b) == a -- all id [(simpleLeftOf a b) == fastLeftOf (toUnary a) (toUnary b) | a <- choose r [1..(2*r)], b <- choose r [1..(2*r)]] fastComplement a = complement ((o `shiftR` 1) .|. (e `shiftL` 1)) where o = odds .&. a e = evens .&. a -- all id [fastComplement (toUnary a) == toUnary (simpleComplement a) | a <- choose r [1..(2*r)]] fastOptions = map toUnary simpleOptions fastCount [] = 1 fastCount (a:as) = fastCount take + fastCount leave where -- take a -- all pairs with b < a or b^c < a are forced -- second case never happens as b^c has 2r but a doesn't take = [b | b <- as, not \$ b `fastLeftOf` a] -- leave a, and so take a^c -- all pairs with b < a^c or b^c < a^c (equivalently, a < b) are forced c = fastComplement a leave = [b | b <- as, not (b `fastLeftOf` c || a `fastLeftOf` b)] permute xs = map snd \$ sort \$ zip noise xs where g = mkStdGen 0 noise = randoms g :: [Int] -- force first i decisions using the bits of x runUp 0 _ as = fastCount as runUp _ x [] = if x == 0 then 1 else 0 -- only count one branch that dies out before the target depth runUp i x (a:as) = if odd x then runUp (i-1) y take else runUp (i-1) y leave where y = x `div` 2 take = [b | b <- as, not \$ b `fastLeftOf` a] c = fastComplement a leave = [b | b <- as, not (b `fastLeftOf` c || a `fastLeftOf` b)] --main = print \$ fastCount \$ permute fastOptions main = do args <- getArgs let [i, x] = map read \$ args let n = runUp i x \$ permute \$ fastOptions putStrLn \$ unwords [show n, show i, show x]