Say you've got a toy grammar, like: (updated so the output looks more natural)
S -> ${NP} ${VP} | ${S} and ${S} | ${S}, after which ${S}
NP -> the ${N} | the ${A} ${N} | the ${A} ${A} ${N}
VP -> ${V} ${NP}
N -> dog | fish | bird | wizard
V -> kicks | meets | marries
A -> red | striped | spotted
e.g., "the dog kicks the red wizard", "the bird meets the spotted fish or the wizard marries the striped dog"
How can you produce a sentence from this grammar according to the constraint that it must contain a total of n Vs + As + Ns. Given an integer the sentence must contain that many terminals. (note of course in this grammar the minimum possible n is 3).
The following Python code will generate a random sentence with the given number of terminals.
It works by counting the number of ways to produce a sentence of a given length, generating a large random number, and computing the indicated sentence.
The count is done recursively, with memoization.
An empty right hand side produces 1 sentence if n is 0 and 0 sentences otherwise.
To count the number of sentences produced by a nonempty right hand side, sum over i, the number of terminals used by the first symbol in the right hand side.
For each i, multiply the number of possibilities for the rest of the right hand side by the number of possibilities for the first symbol.
If the first symbol is a terminal, there is 1 possibility if i is 1 and 0 otherwise.
If the first symbol is a nonterminal, sum the possibilities over each alternative.
To avoid infinite loops, we have to be careful to prune the recursive calls when a quantity is 0.
This may still loop infinitely if the grammar has infinitely many derivations of one sentence.
For example, in the grammar
S -> S S
S ->
there are infinitely many derivations of the empty sentence: S => , S => S S => , S => S S => S S S => , etc.
The code to find a particular sentence is a straightforward modification of the code to count them.
This code is reasonably efficient, generating 100 sentences with 100 terminals each in less than a second.
import collections
import random
class Grammar:
def __init__(self):
self.prods = collections.defaultdict(list)
self.numsent = {}
self.weight = {}
def prod(self, lhs, *rhs):
self.prods[lhs].append(rhs)
self.numsent.clear()
def countsent(self, rhs, n):
if n < 0:
return 0
elif not rhs:
return 1 if n == 0 else 0
args = (rhs, n)
if args not in self.numsent:
sym = rhs[0]
rest = rhs[1:]
total = 0
if sym in self.prods:
for i in xrange(1, n + 1):
numrest = self.countsent(rest, n - i)
if numrest > 0:
for rhs1 in self.prods[sym]:
total += self.countsent(rhs1, i) * numrest
else:
total += self.countsent(rest, n - self.weight.get(sym, 1))
self.numsent[args] = total
return self.numsent[args]
def getsent(self, rhs, n, j):
assert 0 <= j < self.countsent(rhs, n)
if not rhs:
return ()
sym = rhs[0]
rest = rhs[1:]
if sym in self.prods:
for i in xrange(1, n + 1):
numrest = self.countsent(rest, n - i)
if numrest > 0:
for rhs1 in self.prods[sym]:
dj = self.countsent(rhs1, i) * numrest
if dj > j:
j1, j2 = divmod(j, numrest)
return self.getsent(rhs1, i, j1) + self.getsent(rest, n - i, j2)
j -= dj
assert False
else:
return (sym,) + self.getsent(rest, n - self.weight.get(sym, 1), j)
def randsent(self, sym, n):
return self.getsent((sym,), n, random.randrange(self.countsent((sym,), n)))
if __name__ == '__main__':
g = Grammar()
g.prod('S', 'NP', 'VP')
g.prod('S', 'S', 'and', 'S')
g.prod('S', 'S', 'after', 'which', 'S')
g.prod('NP', 'the', 'N')
g.prod('NP', 'the', 'A', 'N')
g.prod('NP', 'the', 'A', 'A', 'N')
g.prod('VP', 'V', 'NP')
g.prod('N', 'dog')
g.prod('N', 'fish')
g.prod('N', 'bird')
g.prod('N', 'wizard')
g.prod('V', 'kicks')
g.prod('V', 'meets')
g.prod('V', 'marries')
g.prod('A', 'red')
g.prod('A', 'striped')
g.prod('A', 'spotted')
g.weight.update({'and': 0, 'after': 0, 'which': 0, 'the': 0})
for i in xrange(100):
print ' '.join(g.randsent('S', 3))
Perhaps not the best solution, but I'd recursively work my way through each rule of the grammar until I've exceeded the constraint, then pop back and explore another path along the grammar. Keep all the sentences that meet the constraint and throw out all the sentences that don't.
For example, with n = 3:
S -> (${NP} ${VP}) -> ( (the ${N}) ${VP}) -> ( (the (dog) ${VP}) -> ... -> ( (the (dog) ( (kicks) (the ${NP} ) ) ) ) -> ( (the (dog) ( (kicks) (the (dog) ) ) ) )
And then pop back
( (the (dog) ( (kicks) (the ${N} ) ) ) ) -> ( (the (dog) ( (kicks) (the (fish) ) ) ) )
and a little while later...
( (the (dog) ( ${V} ${N} ) ) ) -> ( (the (dog) ( (meets) ${N} ) ) ) -> ( (the (dog) ( (meets) the (dog) ) ) )
etc.
Essentially a depth-first graph search, only you are building the graph as you are searching it (and you stop building parts that exceed the constraints).
This question contains a category error. The grammar you've specified has the appearance of a context free grammar, but the requirement that there be a specific number of terminal nodes requires a recursively enumerable grammar.
Related
I'm trying to improve the efficiency of the following code. I want to count all occurrences of a symbol before a given point (as part of pattern-matching using a Burrows-Wheeler transform). There's some overlap in how I'm counting symbols. However, when I have tried to implement what looks like it should be more efficient code, it turns out to be less efficient, and I'm assuming that lazy evaluation and my poor understanding of it is to blame.
My first attempt at a counting function went like this:
count :: Ord a => [a] -> a -> Int -> Int
count list sym pos = length . filter (== sym) . take pos $ list
Then in the body of the matching function itself:
matching str refCol pattern = match 0 (n - 1) (reverse pattern)
where n = length str
refFstOcc sym = length $ takeWhile (/= sym) refCol
match top bottom [] = bottom - top + 1
match top bottom (sym : syms) =
let topCt = count str sym top
bottomCt = count str sym (bottom + 1)
middleCt = bottomCt - topCt
refCt = refFstOcc sym
in if middleCt > 0
then match (refCt + topCt) (refCt + bottomCt - 1) syms
else 0
(Stripped down for brevity - I'm memoizing first occurrences of symbols in refCol through a Map, and a couple other details as well).
Edit: Sample use would be:
matching "AT$TCTAGT" "$AACGTTTT" "TCG"
which should be 1 (assuming I didn't mistype anything).
Now, I'm recounting everything in the middle between the top pointer and the bottom twice, which adds up when I count a million character DNA string with only 4 possible choices for characters (and profiling tells me that this is the big bottleneck, too, taking 48% of my time for bottomCt and around 38% of my time for topCt). For reference, when calculating this for a million character string and trying to match 50 patterns (each of which is between 1 and 1000 characters), the program takes about 8.5 to 9.5 seconds to run.
However, if I try to implement the following function:
countBetween :: Ord a => [a] -> a -> Int -> Int -> (Int, Int)
countBetween list sym top bottom =
let (topList, bottomList) = splitAt top list
midList = take (bottom - top) bottomList
getSyms = length . filter (== sym)
in (getSyms topList, getSyms midList)
(with changes made to the matching function to compensate), the program takes between 18 and 22 seconds to run.
I've also tried passing in a Map which can keep track of previous calls, but that also takes about 20 seconds to run and runs up the memory usage.
Similarly, I've shorted length . filter (== sym) to a fold, but again - 20 seconds for foldr, and 14-15 for foldl.
So what would be a proper Haskell way to optimize this code through rewriting it? (Specifically, I'm looking for something that doesn't involve precomputation - I may not be reusing strings very much - and which explains something of why this is happening).
Edit: More clearly, what I am looking for is the following:
a) Why does this behaviour happen in Haskell? How does lazy evaluation play a role, what optimizations is the compiler making to rewrite the count and countBetween functions, and what other factors may be involved?
b) What is a simple code rewrite which would address this issue so that I don't traverse the lists multiple times? I'm looking specifically for something which addresses that issue, rather than a solution which sidesteps it. If the final answer is, count is the most efficient possible way to write the code, why is that?
I'm not sure lazy evaluation has much to do with the performance of the code. I think the main problem is the use of String - which is a linked list - instead of more performant string type.
Note that this call in your countBetween function:
let (topList, bottomList) = splitAt top list
will re-create the linked link corresponding to topList meaning
a lot more allocations.
A Criterion benchmark to compare splitAt versus using take n/drop n
may be found here: http://lpaste.net/174526. The splitAt version is
about 3 times slower and, of course, has a lot more allocations.
Even if you don't want to "pre-compute" the counts you can improve
matters a great deal by simply switching to either ByteString or Text.
Define:
countSyms :: Char -> ByteString -> Int -> Int -> Int
countSyms sym str lo hi =
length [ i | i <- [lo..hi], BS.index str i == sym ]
and then:
countBetween :: ByteString -> Char -> Int -> Int -> (Int,Int)
countBetween str sym top bottom = (a,b)
where a = countSyms sym str 0 (top-1)
b = countSyms sym str top (bottom-1)
Also, don't use reverse on large lists - it will reallocate the
entire list. Just index into a ByteString / Text in reverse.
Memoizing counts may or may not help. It all depends on how it's done.
It seems that the main point of the match routine is
to transform a interval (bottom,top) to another interval
based on the current symbol sym. The formulas are
basically:
ref_fst = index of sym in ref_col
-- defined in an outer scope
match :: Char -> (Int,Int) -> (Int,Int)
match sym (bottom, top) | bottom > top = (bottom, top) -- if the empty interval
match sym (bottom, top) =
let
top_count = count of sym in str from index 0 to top
bot_count = count of sym in str from index 0 to bottom
mid_count = top_count - bot_count
in if mid_count > 0
then (ref_fst + bot_count, ref_fst + top_count)
else (1,0) -- the empty interval
And then matching is just a fold over pattern using match
with the initial interval (0, n-1).
Both top_count and bot_count can be computed efficiently
using a precomputed lookup table, and below is code which
does that.
If you run test1 you'll see a trace of how the interval
is transformed via each symbol in the pattern.
Note: There may be off-by-1 errors, and I've hard coded
ref_fst to be 0 - I'm not sure how this fits into the
larger algorithm, but the basic idea should be sound.
Note that once the counts vector has been created
there is no need to index into the original string anymore.
Therefore, even though I use a ByteString here for
the (larger) DNA sequence, it's not crucial, and the
mkCounts routine should work just as well if passed a String
instead.
Code also available at http://lpaste.net/174288
{-# LANGUAGE OverloadedStrings #-}
import Data.Vector.Unboxed ((!))
import qualified Data.Vector.Unboxed as UV
import qualified Data.Vector.Unboxed.Mutable as UVM
import qualified Data.ByteString.Char8 as BS
import Debug.Trace
import Text.Printf
import Data.List
mkCounts :: BS.ByteString -> UV.Vector (Int,Int,Int,Int)
mkCounts syms = UV.create $ do
let n = BS.length syms
v <- UVM.new (n+1)
let loop x i | i >= n = return x
loop x i = let s = BS.index syms i
(a,t,c,g) = x
x' = case s of
'A' -> (a+1,t,c,g)
'T' -> (a,t+1,c,g)
'C' -> (a,t,c+1,g)
'G' -> (a,t,c,g+1)
_ -> x
in do UVM.write v i x
loop x' (i+1)
x <- loop (0,0,0,0) 0
UVM.write v n x
return v
data DNA = A | C | T | G
deriving (Show)
getter :: DNA -> (Int,Int,Int,Int) -> Int
getter A (a,_,_,_) = a
getter T (_,t,_,_) = t
getter C (_,_,c,_) = c
getter G (_,_,_,g) = g
-- narrow a window
narrow :: Int -> UV.Vector (Int,Int,Int,Int) -> DNA -> (Int,Int) -> (Int,Int)
narrow refcol counts sym (lo,hi) | trace msg False = undefined
where msg = printf "-- lo: %d hi: %d refcol: %d sym: %s top_cnt: %d bot_count: %d" lo hi refcol (show sym) top_count bot_count
top_count = getter sym (counts ! (hi+1))
bot_count = getter sym (counts ! lo)
narrow refcol counts sym (lo,hi) =
let top_count = getter sym (counts ! (hi+1))
bot_count = getter sym (counts ! (lo+0))
mid_count = top_count - bot_count
in if mid_count > 0
then ( refcol + bot_count, refcol + top_count-1 )
else (lo+1,lo) -- signal an wmpty window
findFirst :: DNA -> UV.Vector (Int,Int,Int,Int) -> Int
findFirst sym v =
let n = UV.length v
loop i | i >= n = n
loop i = if getter sym (v ! i) > 0
then i
else loop (i+1)
in loop 0
toDNA :: String -> [DNA]
toDNA str = map charToDNA str
charToDNA :: Char -> DNA
charToDNA = go
where go 'A' = A
go 'C' = C
go 'T' = T
go 'G' = G
dnaToChar A = 'A'
dnaToChar C = 'C'
dnaToChar T = 'T'
dnaToChar G = 'G'
first :: DNA -> BS.ByteString -> Int
first sym str = maybe len id (BS.elemIndex (dnaToChar sym) str)
where len = BS.length str
test2 = do
-- matching "AT$TCTAGT" "$AACGTTTT" "TCG"
let str = "AT$TCTAGT"
refcol = "$AACGTTTT"
syms = toDNA "TCG"
-- hard coded for now
-- may be computeed an memoized
refcol_G = 4
refcol_C = 3
refcol_T = 5
counts = mkCounts str
w0 = (0, BS.length str -1)
w1 = narrow refcol_G counts G w0
w2 = narrow refcol_C counts C w1
w3 = narrow refcol_T counts T w2
firsts = (first A refcol, first T refcol, first C refcol, first G refcol)
putStrLn $ "firsts: " ++ show firsts
putStrLn $ "w0: " ++ show w0
putStrLn $ "w1: " ++ show w1
putStrLn $ "w2: " ++ show w2
putStrLn $ "w3: " ++ show w3
let (lo,hi) = w3
len = if lo <= hi then hi - lo + 1 else 0
putStrLn $ "length: " ++ show len
matching :: BS.ByteString -> BS.ByteString -> String -> Int
matching str refcol pattern =
let counts = mkCounts str
n = BS.length str
syms = toDNA (reverse pattern)
firsts = (first A refcol, first T refcol, first C refcol, first G refcol)
go (lo,hi) sym = narrow refcol counts sym (lo,hi)
where refcol = getter sym firsts
(lo, hi) = foldl' go (0,n-1) syms
len = if lo <= hi then hi - lo + 1 else 0
in len
test3 = matching "AT$TCTAGT" "$AACGTTTT" "TCG"
I am trying to solve this question in Haskell but the codechef compiler keeps on saying it is the wrong answer. The question is as follows:
After visiting a childhood friend, Chef wants to get back to his home. Friend lives at the first street, and Chef himself lives at the N-th (and the last) street. Their city is a bit special: you can move from the X-th street to the Y-th street if and only if 1 <= Y - X <= K, where K is the integer value that is given to you. Chef wants to get to home in such a way that the product of all the visited streets' special numbers is minimal (including the first and the N-th street). Please, help him to find such a product.
Input
The first line of input consists of two integer numbers - N and K - the number of streets and the value of K respectively. The second line consist of N numbers - A1, A2, ..., AN respectively, where Ai equals to the special number of the i-th street.
The output should be modulo 1000000007
Input
4 2
1 2 3 4
Output
8
The solution I used is as follows:
import qualified Data.ByteString.Char8 as B
import Data.Maybe (fromJust)
findMinIndex x index minIndex n
| index == n = minIndex
| (x!!index) < (x!!minIndex) = findMinIndex x (index+1) index n
| otherwise = findMinIndex x (index+1) minIndex n
minCost [] _ = 1
minCost (x:xs) k = let indexList = take k xs
minIndex = findMinIndex indexList 0 0 (length indexList)
in x * minCost(drop minIndex xs) k
main :: IO()
main = do
t <- B.getContents
let inputs = B.lines t
let firstLine = inputs !! 0
let secondLine = inputs !! 1
let [n,k] = map (fst . fromJust . B.readInt) $ B.split ' ' firstLine
let specialNums = reverse $ map (fst . fromJust . B.readInteger) $ B.split ' ' secondLine
putStrLn $ show ((minCost specialNums k) `mod` 1000000007)
It worked for the given test case and a few other test cases I tries out. But it is not being accepted by codechef. I followed the editorial for the problem and made it. Basically starting from the last number in the list of special numbers the program search it's immediate k predecessors and finds the minimum one in that range and multiplies it with the current value and so on till the beginning of the list
Your algorithm doesn't always give the smallest product for all the inputs, e.g. this one:
5 2
3 2 3 2 3
The editorial explained the problem throughout, you really should read it again.
This problem is basically a shortest path problem, streets are vertices, possible movements from street to street are edges of the graph, the weight of an edge is determined by the special value of the tail alone. While the total movement cost is defined as the product but not the sum of all the costs, the question can be normalized by taking logarithms of all the special values, since
a * b = exp(log(a) + log(b))
Given log is monotonically increasing function, the minimal product is just the minimal sum of logarithms.
In editorial the editor picked Dijkstra's algorithm, but after taking the log transformation, it will be a standard shortest path problem and can be solved with any shortest path algorithm you like.
There are many implementations of Dijkstra's algorithm in Haskell, I found two on Hackage and one here. The parsing and graph initializing code is straight forward.
import Control.Monad (foldM)
import Control.Monad.ST
import Data.Array
import Data.Array.MArray
import Data.Array.ST
import Data.Function (on)
import Data.IntMap.Strict as M
import Data.List (groupBy)
import Data.Set as S
-- Code from http://rosettacode.org/wiki/Dijkstra's_algorithm#Haskell
dijkstra :: (Ix v, Num w, Ord w, Bounded w) => v -> v -> Array v [(v,w)] -> (Array v w, Array v v)
dijkstra src invalid_index adj_list = runST $ do
min_distance <- newSTArray b maxBound
writeArray min_distance src 0
previous <- newSTArray b invalid_index
let aux vertex_queue =
case S.minView vertex_queue of
Nothing -> return ()
Just ((dist, u), vertex_queue') ->
let edges = adj_list Data.Array.! u
f vertex_queue (v, weight) = do
let dist_thru_u = dist + weight
old_dist <- readArray min_distance v
if dist_thru_u >= old_dist then
return vertex_queue
else do
let vertex_queue' = S.delete (old_dist, v) vertex_queue
writeArray min_distance v dist_thru_u
writeArray previous v u
return $ S.insert (dist_thru_u, v) vertex_queue'
in
foldM f vertex_queue' edges >>= aux
aux (S.singleton (0, src))
m <- freeze min_distance
p <- freeze previous
return (m, p)
where b = bounds adj_list
newSTArray :: Ix i => (i,i) -> e -> ST s (STArray s i e)
newSTArray = newArray
shortest_path_to :: (Ix v) => v -> v -> Array v v -> [v]
shortest_path_to target invalid_index previous =
aux target [] where
aux vertex acc | vertex == invalid_index = acc
| otherwise = aux (previous Data.Array.! vertex) (vertex : acc)
-- Code I wrote
instance Bounded Double where
minBound = -1e100
maxBound = 1e100
constructInput :: Int -> Int -> M.IntMap Integer -> Array Int [(Int, Double)]
constructInput n k specMap =
let
specMap' = fmap (log . fromIntegral) specMap
edges = [(src, [(dest, specMap' M.! dest) | dest <- [src+1..src+k], dest <= n]) | src <- [1..n]]
in
array (1, n) edges
main :: IO ()
main = do
rawInput <- getContents
let
[l, l'] = lines rawInput
[n,k] = fmap read . words $ l
specs = fmap read . words $ l'
specMap = M.fromList $ [1..n] `zip` specs
adj_list = constructInput n k specMap
(_, previous) = dijkstra 1 0 adj_list
path = shortest_path_to n 0 previous
weight = (product $ fmap (specMap M.!) path) `mod` 1000000007
print weight
PS: My program scores 30 with a lot of TLE (short for "Too Long Execution" I guess) on CodeChief, for the full mark you may have to try it yourself and get a better solution.
I am trying to solve some issues with programming in haskell.
I am having this three types and the Hanoi-algorithm:
type Position = Int
type Move = (Position,Position)
type Towers = ([Int],[Int],[Int])
hanoi 1 i j = [(i,j)]
hanoi n i j = hanoi n' i otherT ++ [(i,j)] ++ hanoi n' otherT j
where
n' = n-1
otherT = 1+2+3-i-j -- other tower
Now I wrote a function with makes one single MOVE.
move ::([Move],Towers) -> ([Move],Towers)
move ::([Move],Towers) -> ([Move],Towers)
move ([],(xs,ys,zs) ) = ((error "Error"),(xs,ys,zs) )
move (((a,b): tail), (xs,ys,zs) )
| a > 3 = (tail, ((error "Error"),ys,zs) )
| b > 3 = (tail, ((error "Error"),ys,zs ) )
| otherwise = hilfsfunktion (((a,b): tail), (xs,ys,zs) )
hilfsfunktion (((1,2): tail), ((x:xs),(y:ys),zs) )
| x < y = (tail, (xs, (x:y:ys),zs) )
| x > y = (tail, (xs, (error "too big"),(error "too big")))
hilfsfunktion (((1,2): tail), ((x:xs), [],zs) ) = (tail, (xs, x:[],zs) )
The function is much longer, but you can see that I solved this with Pattern Matching.
Now I try to write a function, that called this "move"-function as long as the list is not empty. So at first I used Pattern Matching for the case, that the list is empty.
all_moves:: ([Move], Towers) -> Towers
all_moves ([],(xs,ys,zs) ) = (xs,ys,zs)
all_moves (((a,b): tail), (xs,ys,zs) ) = ????
Now I need some help, in Java I would use a loop to fix this. I think I have to call the function "move" recursive, but I don't know how to to this.
How can I solve this function?
I'm not sure exactly how your hanoi solution works, but I think this answers your question:
all_moves :: ([Move], Towers) -> Towers
all_moves ([], (xs, ys, zs)) = (xs, ys, zs)
all_moves movetowers = all_moves (move movetowers)
Hopefully you can see why this works - we keep doing a move and then a recursive call until there are no moves left.
I would like to do like this way even though my method is nor recursive as well.
allllmove :: Towers -> Towers
allmove ([0],[0],[0]) = ([0],[0],[0])
allmove ((x:xs),y,z)
length(x:xs) > length z && length z > length y = (xs,(x:y),z)
length(x:xs) >= length z && length (x:xs) > length y = (xs,(x:y),z)
...
..
.
Suppose we have a simple grammar specification. There is a way to enumerate terms of that grammar that guarantees that any finite term will have a finite position, by iterating it diagonally. For example, for the following grammar:
S ::= add
add ::= mul | add + mul
mul ::= term | mul * term
term ::= number | ( S )
number ::= digit | digit number
digit ::= 0 | 1 | ... | 9
You can enumerate terms like that:
0
1
0+0
0*0
0+1
(0)
1+0
0*1
0+0*0
00
... etc
My question is: is there a way to do the opposite? That is, to take a valid term of that grammar, say, 0+0*0, and find its position on such enumeration - in that case, 9?
For this specific problem, we can cook up something fairly simple, if we allow ourselves to choose a different enumeration ordering. The idea is basically the one in Every Bit Counts, which I also mentioned in the comments. First, some preliminaries: some imports/extensions, a data type representing the grammar, and a pretty-printer. For the sake of simplicity, my digits only go up to 2 (big enough to not be binary any more, but small enough not to wear out my fingers and your eyes).
{-# LANGUAGE TypeSynonymInstances #-}
import Control.Applicative
import Data.Universe.Helpers
type S = Add
data Add = Mul Mul | Add :+ Mul deriving (Eq, Ord, Show, Read)
data Mul = Term Term | Mul :* Term deriving (Eq, Ord, Show, Read)
data Term = Number Number | Parentheses S deriving (Eq, Ord, Show, Read)
data Number = Digit Digit | Digit ::: Number deriving (Eq, Ord, Show, Read)
data Digit = D0 | D1 | D2 deriving (Eq, Ord, Show, Read, Bounded, Enum)
class PP a where pp :: a -> String
instance PP Add where
pp (Mul m) = pp m
pp (a :+ m) = pp a ++ "+" ++ pp m
instance PP Mul where
pp (Term t) = pp t
pp (m :* t) = pp m ++ "*" ++ pp t
instance PP Term where
pp (Number n) = pp n
pp (Parentheses s) = "(" ++ pp s ++ ")"
instance PP Number where
pp (Digit d) = pp d
pp (d ::: n) = pp d ++ pp n
instance PP Digit where pp = show . fromEnum
Now let's define the enumeration order. We'll use two basic combinators, +++ for interleaving two lists (mnemonic: the middle character is a sum, so we're taking elements from either the first argument or the second) and +*+ for the diagonalization (mnemonic: the middle character is a product, so we're taking elements from both the first and second arguments). More information on these in the universe documentation. One invariant we'll maintain is that our lists -- with the exception of digits -- are always infinite. This will be important later.
ss = adds
adds = (Mul <$> muls ) +++ (uncurry (:+) <$> adds +*+ muls)
muls = (Term <$> terms ) +++ (uncurry (:*) <$> muls +*+ terms)
terms = (Number <$> numbers) +++ (Parentheses <$> ss)
numbers = (Digit <$> digits) ++ interleave [[d ::: n | n <- numbers] | d <- digits]
digits = [D0, D1, D2]
Let's see a few terms:
*Main> mapM_ (putStrLn . pp) (take 15 ss)
0
0+0
0*0
0+0*0
(0)
0+0+0
0*(0)
0+(0)
1
0+0+0*0
0*0*0
0*0+0
(0+0)
0+0*(0)
0*1
Okay, now let's get to the good bit. Let's assume we have two infinite lists a and b. There's two things to notice. First, in a +++ b, all the even indices come from a, and all the odd indices come from b. So we can look at the last bit of an index to see which list to look in, and the remaining bits to pick an index in that list. Second, in a +*+ b, we can use the standard bijection between pairs of numbers and single numbers to translate between indices in the big list and pairs of indices in the a and b lists. Nice! Let's get to it. We'll define a class for Godel-able things that can be translated back and forth between numbers -- indices into the infinite list of inhabitants. Later we'll check that this translation matches the enumeration we defined above.
type Nat = Integer -- bear with me here
class Godel a where
to :: a -> Nat
from :: Nat -> a
instance Godel Nat where to = id; from = id
instance (Godel a, Godel b) => Godel (a, b) where
to (m_, n_) = (m + n) * (m + n + 1) `quot` 2 + m where
m = to m_
n = to n_
from p = (from m, from n) where
isqrt = floor . sqrt . fromIntegral
base = (isqrt (1 + 8 * p) - 1) `quot` 2
triangle = base * (base + 1) `quot` 2
m = p - triangle
n = base - m
The instance for pairs here is the standard Cantor diagonal. It's just a bit of algebra: use the triangle numbers to figure out where you're going/coming from. Now building up instances for this class is a breeze. Numbers are just represented in base 3:
-- this instance is a lie! there aren't infinitely many Digits
-- but we'll be careful about how we use it
instance Godel Digit where
to = fromIntegral . fromEnum
from = toEnum . fromIntegral
instance Godel Number where
to (Digit d) = to d
to (d ::: n) = 3 + to d + 3 * to n
from n
| n < 3 = Digit (from n)
| otherwise = let (q, r) = quotRem (n-3) 3 in from r ::: from q
For the remaining three types, we will, as suggested above, check the tag bit to decide which constructor to emit, and use the remaining bits as indices into a diagonalized list. All three instances necessarily look very similar.
instance Godel Term where
to (Number n) = 2 * to n
to (Parentheses s) = 1 + 2 * to s
from n = case quotRem n 2 of
(q, 0) -> Number (from q)
(q, 1) -> Parentheses (from q)
instance Godel Mul where
to (Term t) = 2 * to t
to (m :* t) = 1 + 2 * to (m, t)
from n = case quotRem n 2 of
(q, 0) -> Term (from q)
(q, 1) -> uncurry (:*) (from q)
instance Godel Add where
to (Mul m) = 2 * to m
to (m :+ t) = 1 + 2 * to (m, t)
from n = case quotRem n 2 of
(q, 0) -> Mul (from q)
(q, 1) -> uncurry (:+) (from q)
And that's it! We can now "efficiently" translate back and forth between parse trees and their Godel numbering for this grammar. Moreover, this translation matches the above enumeration, as you can verify:
*Main> map from [0..29] == take 30 ss
True
We did abuse many nice properties of this particular grammar -- non-ambiguity, the fact that almost all the nonterminals had infinitely many derivations -- but variations on this technique can get you quite far, especially if you are not too strict on requiring every number to be associated with something unique.
Also, by the way, you might notice that, except for the instance for (Nat, Nat), these Godel numberings are particularly nice in that they look at/produce one bit (or trit) at a time. So you could imagine doing some streaming. But the (Nat, Nat) one is pretty nasty: you have to know the whole number ahead of time to compute the sqrt. You actually can turn this into a streaming guy, too, without losing the property of being dense (every Nat being associated with a unique (Nat, Nat)), but that's a topic for another answer...
I've spent almost all competition time(3 h) for solving this problem. In vain :( Maybe you could help me to find the solution.
A group of Facebook employees just had a very successful product launch. To celebrate, they have decided to go wine tasting. At the vineyard, they decide to play a game. One person is given some glasses of wine, each containing a different wine. Every glass of wine is labelled to indicate the kind of wine the glass contains. After tasting each of the wines, the labelled glasses are removed and the same person is given glasses containing the same wines, but unlabelled. The person then needs to determine which of the unlabelled glasses contains which wine. Sadly, nobody in the group can tell wines apart, so they just guess randomly. They will always guess a different type of wine for each glass. If they get enough right, they win the game. You must find the number of ways that the person can win, modulo 1051962371.
Input
The first line of the input is the number of test cases, N. The next N lines each contain a test case, which consists of two integers, G and C, separated by a single space. G is the total number of glasses of wine and C is the minimum number that the person must correctly identify to win.
Constraints
N = 20
1 ≤ G ≤ 100
1 ≤ C ≤ G
Output
For each test case, output a line containing a single integer, the number of ways that the person can win the game modulo 1051962371.
Example input
5
1 1
4 2
5 5
13 10
14 1
Example output
1
7
1
651
405146859
Here's the one that doesn't need the prior knowledge of Rencontres numbers. (Well, it's basically the proof a formula from the wiki but I thought I'd share it anyway.)
First find f(n): the number of permutations of n elements that don't have a fixed point. It's simple by inclusion-exclusion formula: the number of permutations that fix k given points is (n-k)!, and these k points can be chosen in C(n,k) ways. So, f(n) = n! - C(n,1)(n-1)! + C(n,2)(n-2)! - C(n,3)(n-3)! + ...
Now find the number of permutations that have exactly k fixed points. These points can be chosen in C(n,k) ways and the rest n-k points can be rearranged in f(n-k) ways. So, it's C(n,k)f(n-k).
Finally, the answer to the problem is the sum of C(g,k)f(g-k) over k = c, c+1, ..., g.
My solution involved the use of Rencontres Numbers.
A Rencontres Number D(n,k) is the number of permutations of n elements where exactly k elements are in their original places. The problem asks for at least k elemenets, so I just took the sum over k, k+1,...,n.
Here's my Python submission (after cleaning up):
from sys import stdin, stderr, setrecursionlimit as recdepth
from math import factorial as fact
recdepth(100000)
MOD=1051962371
cache=[[-1 for i in xrange(101)] for j in xrange(101)]
def ncr(n,k):
return fact(n)/fact(k)/fact(n-k)
def D(n,k):
if cache[n][k]==-1:
if k==0:
if n==0:
cache[n][k]=1
elif n==1:
cache[n][k]=0
else:
cache[n][k]= (n-1)*(D(n-1,0)+D(n-2,0))
else:
cache[n][k]=ncr(n,k)*D(n-k,0)
return cache[n][k]
return cache[n][k]
def answer(total, match):
return sum(D(total,i) for i in xrange(match,total+1))%MOD
if __name__=='__main__':
cases=int(stdin.readline())
for case in xrange(cases):
stderr.write("case %d:\n"%case)
G,C=map(int,stdin.readline().split())
print answer(G,C)
from sys import stdin, stderr, setrecursionlimit as recdepth
from math import factorial as fact
recdepth(100000)
MOD=1051962371
cache=[[-1 for i in xrange(101)] for j in xrange(101)]
def ncr(n,k):
return fact(n)/fact(k)/fact(n-k)
def D(n,k):
if cache[n][k]==-1:
if k==0:
if n==0:
cache[n][k]=1
elif n==1:
cache[n][k]=0
else:
cache[n][k]= (n-1)*(D(n-1,0)+D(n-2,0))
else:
cache[n][k]=ncr(n,k)*D(n-k,0)
return cache[n][k]
return cache[n][k]
def answer(total, match):
return sum(D(total,i) for i in xrange(match,total+1))%MOD
if __name__=='__main__':
cases=int(stdin.readline())
for case in xrange(cases):
stderr.write("case %d:\n"%case)
G,C=map(int,stdin.readline().split())
print answer(G,C)
Like everyone else, I computed the function that I now know is Rencontres Numbers, but I derived the recursive equation myself in the contest. Without loss of generality, we simply assume the correct labels of wines are 1, 2, .., g, i.e., not permuted at all.
Let's denote the function as f(g,c). Given g glasses, we look at the first glass, and we could either label it right, or label it wrong.
If we label it right, we reduce the problem to getting c-1 right out of g-1 glasses, i.e., f(g-1, c-1).
If we label it wrong, we have g-1 choices for the first glass. For the remaining g-1 glasses, we must get c glasses correct, but this subproblem is different from the f we're computing, because out of the g-1 glasses, there's already a mismatching glass. To be more precise, for the first glass, our answer is j instead of the correct label 1. Let's assume there's another function h that computes it for us.
So we have f(g,c) = f(g-1,c-1) + (g-1) * h(g-1, c).
Now to compute h(g,c), we need to consider two cases at the jth glass.
If we label it 1, we reduce the problem to f(g-1,c).
If we label it k, we have g-1 choices, and the problem is reduced to h(g-1,c).
So we have h(g,c) = f(g-1,c) + (g-1) * h(g-1,c).
Here's the complete program in Haskell, with memoization and some debugging support.
import Control.Monad
import Data.MemoTrie
--import Debug.Trace
trace = flip const
add a b = mod (a+b) 1051962371
mul a b = mod (a*b) 1051962371
main = do
(_:input) <- liftM words getContents
let map' f [] = []
map' f (a:c:xs) = f (read a) (read c) : map' f xs
mapM print $ map' ans input
ans :: Integer -> Integer -> Integer
ans g c = foldr add 0 $ map (f g) [c..g]
memoF = memo2 f
memoH = memo2 h
-- Exactly c correct in g
f :: Integer -> Integer -> Integer
f g c = trace ("f " ++ show (g,c) ++ " = " ++ show x) x
where x = if c < 0 || g < c then 0
else if g == c then 1
else add (memoF (g-1) (c-1)) (mul (g-1) (memoH (g-1) c))
-- There's one mismatching position in g positions
h :: Integer -> Integer -> Integer
h g c = trace ("h " ++ show (g,c) ++ " = " ++ show x) x
where x = if c < 0 || g < c then 0
else add (memoF (g-1) c) (mul (g-1) (memoH (g-1) c))