I'm trying to find the first 100,000 binary digits in the expansion of 'e'. Is there an algorithm to generate the binary digits of 'e' as a infinite list?
Here's an unbounded spigot for e in Haskell:
main = print $ stream (1,0,1) [(n, a*d, d) | (n,d,a) <- map f [1..]]
where
f k = (1, k, 1)
stream z (x:xs)
| lbound == approx z 2 = lbound : stream (mul (10, -10*lbound, 1) z) (x:xs)
| otherwise = stream (mul z x) xs
where
lbound = approx z 1
approx (a,b,c) n = (a*n + b) `div` c
mul (a,b,c) (d,e,f) = (a*d, a*e + b*f, c*f)
Based on the Programming Praxis unbounded spigot for e and pi, which in turn is derived from Gibbon's first unbounded spigot for pi.
$ runhaskell A.hs
[2,7,1,8,2,8,1,8,2,8,4,5,9,0,4,5,2,3,5,3,6, ^C
I'd recommend Gibbon's paper if you're interested in these fun algorithms.
You might be interested in using CReal for this. For 100,000 binary digits, 30,200 decimal digits is enough:
Prelude> 100000 * logBase 10 2
30102.999566398114
Prelude> :m + Data.Number.CReal
Prelude> :set +s
Prelude Data.Number.CReal> last $ showCReal 1000 (exp 1)
'4'
(0.34 secs, 34061824 bytes)
Prelude Data.Number.CReal> last $ showCReal 2000 (exp 1)
'4'
(1.25 secs, 104478784 bytes)
Prelude Data.Number.CReal> last $ showCReal 4000 (exp 1)
'7'
(5.96 secs, 355775928 bytes)
Prelude Data.Number.CReal> last $ showCReal 8000 (exp 1)
'2'
(20.89 secs, 1298942504 bytes)
This pattern looks about quadratic to me, so computing the first 30,200 digits of exp 1 looks like it might reasonably finish in about five or six minutes here on my machine. A patch to output in binary directly (and therefore avoid converting to decimal and back) would likely be accepted.
edit: Projection satisfied, just under six minutes of compute time!
Prelude Data.Number.CReal> showCReal 30200 (exp 1)
"2.718281828459045235360287471352662497757247093699959574966967627724076630353547594571382178525166427427466391932003059921817413596629043572900334...middle snipped due to StackOverflow message limit...39106913376148418348845963656215266103322394174671"
(349.44 secs, 17096829912 bytes)
Related
I am learning parallel programming in Haskell using Simon Marlow's book. In the chapter about parallelizing Sudoku solvers, I decided to write my own solver using backtracking algorithm. The problem is that there is almost no performance gain when I try to distribute 6 cases among 6 cores. When I try to do examples with more cases, I get more significant performance gains yet still far from theoretical maximum which should be between 5 and 6. I understand that some cases may run far slower, but the threadscope diagram shows no excuse for such little gain.
Can someone explain me what I am doing wrong. Maybe there is something about ST threads which I am not understanding?
Here is the code:
Sudoku.hs
{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
module Sudoku (getSudokus, solve) where
import Data.Vector(Vector, (!), generate, thaw, freeze)
import Data.List ( nub )
import qualified Data.Vector.Mutable as MV
import Text.Trifecta
import Control.Monad ( replicateM, when )
import Control.Applicative ((<|>))
import Control.Monad.ST
import Control.DeepSeq (NFData)
import GHC.Generics (Generic)
data Cell = Given Int
| Filled Int
| Empty
deriving (Generic, NFData)
newtype Sudoku = Sudoku (Vector Cell)
deriving (Generic, NFData)
instance Show Cell where
show Empty = " "
show (Filled x) = " " ++ show x ++ " "
show (Given x) = "[" ++ show x ++ "]"
instance Show Sudoku where
show (Sudoku vc) = "\n" ++
"+ - - - + - - - + - - - +" ++ "\n" ++
"|" ++ i 0 ++ i 1 ++ i 2 ++ "|" ++ i 3 ++ i 4 ++ i 5 ++ "|" ++ i 6 ++ i 7 ++ i 8 ++ "|" ++ "\n" ++
"|" ++ i 9 ++ i 10 ++ i 11 ++ "|" ++ i 12 ++ i 13 ++ i 14 ++ "|" ++ i 15 ++ i 16 ++ i 17 ++ "|" ++ "\n" ++
"|" ++ i 18 ++ i 19 ++ i 20 ++ "|" ++ i 21 ++ i 22 ++ i 23 ++ "|" ++ i 24 ++ i 25 ++ i 26 ++ "|" ++ "\n" ++
"+ - - - + - - - + - - - +" ++ "\n" ++
"|" ++ i 27 ++ i 28 ++ i 29 ++ "|" ++ i 30 ++ i 31 ++ i 32 ++ "|" ++ i 33 ++ i 34 ++ i 35 ++ "|" ++ "\n" ++
"|" ++ i 36 ++ i 37 ++ i 38 ++ "|" ++ i 39 ++ i 40 ++ i 41 ++ "|" ++ i 42 ++ i 43 ++ i 44 ++ "|" ++ "\n" ++
"|" ++ i 45 ++ i 46 ++ i 47 ++ "|" ++ i 48 ++ i 49 ++ i 50 ++ "|" ++ i 51 ++ i 52 ++ i 53 ++ "|" ++ "\n" ++
"+ - - - + - - - + - - - +" ++ "\n" ++
"|" ++ i 54 ++ i 55 ++ i 56 ++ "|" ++ i 57 ++ i 58 ++ i 59 ++ "|" ++ i 60 ++ i 61 ++ i 62 ++ "|" ++ "\n" ++
"|" ++ i 63 ++ i 64 ++ i 65 ++ "|" ++ i 66 ++ i 67 ++ i 68 ++ "|" ++ i 69 ++ i 70 ++ i 71 ++ "|" ++ "\n" ++
"|" ++ i 72 ++ i 73 ++ i 74 ++ "|" ++ i 75 ++ i 76 ++ i 77 ++ "|" ++ i 78 ++ i 79 ++ i 80 ++ "|" ++ "\n" ++
"+ - - - + - - - + - - - +" ++ "\n"
where i x = show (vc ! x)
parseSudoku :: Parser Sudoku
parseSudoku = do
lst <- replicateM 81 field
(newline *> return ()) <|> eof
return $ Sudoku $ generate 81 (lst !!)
where field = (char '.' >> return Empty) <|> (Given . read . return <$> digit)
getSudokus :: String -> Maybe [Sudoku]
getSudokus raw = case parseString (some parseSudoku) mempty raw of
Success ss -> Just ss
Failure _ -> Nothing
data Direction = Back | Forward
solve :: Sudoku -> Maybe Sudoku
solve sudoku#(Sudoku puzzle) = if isValid sudoku then
Just $ runST $ do
puzzle' <- thaw puzzle
go puzzle' 0 Forward
Sudoku <$> freeze puzzle'
else Nothing
where go _ 81 _ = return ()
go vector position direction = do
cell <- MV.read vector position
case (cell, direction) of
(Empty, Back) -> error "Calling back Empty cell, this should not ever occur"
(Empty, Forward) -> MV.write vector position (Filled 1) >> go vector position Forward
(Given _, Back) -> go vector (position-1) Back
(Given _, Forward) -> go vector (position+1) Forward
(Filled 10, Back) -> MV.write vector position Empty >> go vector (position-1) Back
(Filled 10, Forward) -> go vector position Back
(Filled x, Forward) -> do
let (r, c, s) = calculatePositions position
row <- getRowMV r vector
col <- getColumnMV c vector
sqr <- getSquareMV s vector
if isUnique row && isUnique col && isUnique sqr
then go vector (position+1) Forward
else MV.write vector position (Filled (x+1)) >> go vector position Forward
(Filled x, Back) -> MV.write vector position (Filled (x+1)) >> go vector position Forward
calculatePositions :: Int -> (Int, Int, Int)
calculatePositions i = let (row, col) = divMod i 9
sqr = (row `div` 3)*3 + (col `div` 3)
in (row, col, sqr)
isValid :: Sudoku -> Bool
isValid sudoku = go 0
where go 9 = True
go i = isUnique (getRow i sudoku) && isUnique (getColumn i sudoku) && isUnique (getSquare i sudoku) && go (i+1)
getRow :: Int -> Sudoku -> [Cell]
getRow l (Sudoku vector) = go 0
where go 9 = []
go c = vector ! (l*9 + c) : go (c+1)
getRowMV :: MV.PrimMonad m => Int -> MV.MVector (MV.PrimState m) Cell -> m [Cell]
getRowMV l mv = go 0
where go 9 = return []
go c = do
n <- MV.read mv (l*9 + c)
rl <- go (c+1)
return (n:rl)
getColumn :: Int -> Sudoku -> [Cell]
getColumn c (Sudoku vector) = go 0
where go 9 = []
go i = vector ! (c + i*9) : go (i+1)
getColumnMV :: MV.PrimMonad m => Int -> MV.MVector (MV.PrimState m) Cell -> m [Cell]
getColumnMV c mv = go 0
where go 9 = return []
go i = do
n <- MV.read mv (c + i*9)
rl <- go (i+1)
return (n:rl)
getSquare :: Int -> Sudoku -> [Cell]
getSquare q (Sudoku vector) = let (y, x) = quotRem q 3
start = x*3 + y*3*9
in [ vector ! start, vector ! (start + 1), vector ! (start + 2)
, vector ! (start + 9), vector ! (start + 10), vector ! (start + 11)
, vector ! (start + 18), vector ! (start + 19), vector ! (start + 20)]
getSquareMV :: MV.PrimMonad m => Int -> MV.MVector (MV.PrimState m) a -> m [a]
getSquareMV q mv = let (y, x) = quotRem q 3
start = x*3 + y*3*9
in do
a1 <- MV.read mv start
a2 <- MV.read mv (start + 1)
a3 <- MV.read mv (start + 2)
b1 <- MV.read mv (start + 9)
b2 <- MV.read mv (start + 10)
b3 <- MV.read mv (start + 11)
c1 <- MV.read mv (start + 18)
c2 <- MV.read mv (start + 19)
c3 <- MV.read mv (start + 20)
return [a1,a2,a3,b1,b2,b3,c1,c2,c3]
isUnique :: [Cell] -> Bool
isUnique xs = let sv = strip xs
in length sv == length (nub sv)
where strip (Empty:xs) = strip xs
strip ((Given x):xs) = x : strip xs
strip ((Filled x):xs) = x : strip xs
strip [] = []
Main.hs
module Main where
import Control.Parallel.Strategies
import Control.Monad
import Control.DeepSeq ( force )
import Sudoku
import System.Environment (getArgs)
main :: IO ()
main = do
filename <- head <$> getArgs
contents <- readFile filename
case getSudokus contents of
Just sudokus -> print $ runEval $ do
start <- forM sudokus (rpar . force . solve)
forM start rseq
Nothing -> putStrLn "Error during parsing"
I am compiling it with following flags:
ghc-options: -O2 -rtsopts -threaded -eventlog
Execution with following flags:
cabal exec sudoku -- sudoku17.6.txt +RTS -N1 -s -l
Gives following performance report and threadscope diagram:
950,178,477,200 bytes allocated in the heap
181,465,696 bytes copied during GC
121,832 bytes maximum residency (7 sample(s))
30,144 bytes maximum slop
7 MiB total memory in use (0 MB lost due to fragmentation)
Tot time (elapsed) Avg pause Max pause
Gen 0 227776 colls, 0 par 1.454s 1.633s 0.0000s 0.0011s
Gen 1 7 colls, 0 par 0.001s 0.001s 0.0001s 0.0002s
TASKS: 4 (1 bound, 3 peak workers (3 total), using -N1)
SPARKS: 6 (0 converted, 0 overflowed, 0 dud, 0 GC'd, 6 fizzled)
INIT time 0.001s ( 0.001s elapsed)
MUT time 220.452s (220.037s elapsed)
GC time 1.455s ( 1.634s elapsed)
EXIT time 0.000s ( 0.008s elapsed)
Total time 221.908s (221.681s elapsed)
Alloc rate 4,310,140,685 bytes per MUT second
Productivity 99.3% of total user, 99.3% of total elapsed
Execution with parallelization:
cabal exec sudoku -- sudoku17.6.txt +RTS -N6 -s -l
950,178,549,616 bytes allocated in the heap
325,450,104 bytes copied during GC
142,704 bytes maximum residency (7 sample(s))
82,088 bytes maximum slop
32 MiB total memory in use (0 MB lost due to fragmentation)
Tot time (elapsed) Avg pause Max pause
Gen 0 128677 colls, 128677 par 37.697s 30.612s 0.0002s 0.0035s
Gen 1 7 colls, 6 par 0.005s 0.004s 0.0006s 0.0012s
Parallel GC work balance: 11.66% (serial 0%, perfect 100%)
TASKS: 14 (1 bound, 13 peak workers (13 total), using -N6)
SPARKS: 6 (5 converted, 0 overflowed, 0 dud, 0 GC'd, 1 fizzled)
INIT time 0.010s ( 0.009s elapsed)
MUT time 355.227s (184.035s elapsed)
GC time 37.702s ( 30.616s elapsed)
EXIT time 0.001s ( 0.007s elapsed)
Total time 392.940s (214.667s elapsed)
Alloc rate 2,674,847,755 bytes per MUT second
Productivity 90.4% of total user, 85.7% of total elapsed
Here are the contents of sudoku17.6.txt:
.......2143.......6........2.15..........637...........68...4.....23........7....
.......241..8.............3...4..5..7.....1......3.......51.6....2....5..3...7...
.......24....1...........8.3.7...1..1..8..5.....2......2.4...6.5...7.3...........
.......23.1..4....5........1.....4.....2...8....8.3.......5.16..4....7....3......
.......21...5...3.4..6.........21...8.......75.....6.....4..8...1..7.....3.......
.......215.3......6...........1.4.6.7.....5.....2........48.3...1..7....2........
Believe it or not, but your problem potentially had nothing to do with parallelization. In the future I'd recommend you first look at the input to the function you are trying to parallelized. It turned out you always tried a single puzzle.
Edit - #Noughtmare pointed out that according to Threadscope results posted in the question there is some parallelization going on. Which is true and it makes me believe that the file posted in question doesn't exactly match the one used for creating the results. If that's the case, then you can skip to Parallelization section for the answer about: "Why parallelizing this code yields almost no performance improvement on six core machine?"
Parser
Long story short there is a bug in your parser. If you ask my true opinion, it is actually a bug in trifecta package documentation, because it promises to fully consume the input parseString:
Fully parse a String to a Result.
but instead it consumes the first line only and successfully returns the result. However, honestly, I've never used it before, so maybe it is the expected bahavior.
Lets take a look at your parser:
parseSudoku :: Parser Sudoku
parseSudoku = do
lst <- replicateM 81 field
(newline *> return ()) <|> eof
return $ Sudoku $ generate 81 (lst !!)
where
field = (char '.' >> return Empty) <|> (Given . read . return <$> digit)
At first glance it looks just fine, until input is closely examined. Every empty line between the lines with data also contain a newline character, but your parser expects one at most:
.......2143.......6........2.15..........637...........68...4.....23........7....
<this is also a newline>
.......241..8.............3...4..5..7.....1......3.......51.6....2....5..3...7...
So you parser should instead be:
many (newline *> return ()) <|> eof
Side note. If it was up to me this is how I would write the parser:
parseSudoku :: Parser Sudoku
parseSudoku = do
(Sudoku <$> V.replicateM 81 field) <* ((() <$ many newline) <|> eof)
where
field = (Empty <$ char '.') <|> (Given . Data.Char.digitToInt <$> digit)
Parallelization
When it comes to implementation of parallelization it seems to work fine, but the problem is the work load is really unbalanced. That's why there is only about x2 speed up when using 6 cores. In other words not all puzzles are created equally hard. For that reason solving 6 puzzles using 6 cores in parallel will always get the performance of the longest solution at best. Therefore to gain more from parallelization you either need more puzzles or less CPU cores ;)
EDIT: Here are some benchmarks to support my explanation above.
These are the results for solving each individual puzzle:
And these two are the sequential and parallelized solvers using one core and six cores respectfully.
As you can see solving the second puzzle with index 1 took the longest time, which on my computer took a little over a 100 seconds. This is also the time it took for the parallelized algorithm to solve all puzzles. Which makes sense, since all other 5 puzzles were solved much quicker and those cores that were freed up had no other work to do.
Also as a sanity check if you sum up the individual times it took for puzzles to be solved it will match up pretty good with the total time it took to solve all of them sequentially.
I have this code:
project= [
[(a,b),(c,d),(e,f)]
|
a<-[1..5],
b<-[1..3],
c<-[1..5],
d<-[1..3],
e<-[1..5],
f<-[1..3]
, a*b + c*d + e*f <6
, a + c + e == 5
, b == 3 || d==3 || f==3
]
x=take 1 project
main = print $ x
it is return a list of 3 pairs [(x,y),(x,y),(x,y)] .
There are 3 conditions:
If you sum all the x you must get 5.
If you sum all the x*y you will get less than 6.
There is at least one y that equal to 3.
Now, I want exactly the same algorithm to work for any longer list for example 10 pairs. How should I do that?
Here:
project n =
[ x
| x <- replicateM n $ liftA2 (,) [1..5] [1..3]
, sum (map (uncurry (*)) x) < 6
, sum (map fst x) == 5
, any ((==3) . snd) x
]
main = print $ take 1 $ project 3
Or like so:
project n
= filter (any ((==3) . snd))
$ filter ((==5) . sum . map fst)
$ filter ((<6) . sum . map (uncurry (*)))
$ replicateM n
$ liftA2 (,) [1..5] [1..3]
I'm looking for an efficient algorithm for computing the multiplicative partitions for any given integer. For example, the number of such partitions for 12 is 4, which are
12 = 12 x 1 = 4 x 3 = 2 x 2 x 3 = 2 x 6
I've read the wikipedia article for this, but that doesn't really give me an algorithm for generating the partitions (it only talks about the number of such partitions, and to be honest, even that is not very clear to me!).
The problem I'm looking at requires me to compute multiplicative partitions for very large numbers (> 1 billion), so I was trying to come up with a dynamic programming approach for it (so that finding all possible partitions for a smaller number can be re-used when that smaller number is itself a factor of a bigger number), but so far, I don't know where to begin!
Any ideas/hints would be appreciated - this is not a homework problem, merely something I'm trying to solve because it seems so interesting!
The first thing I would do is get the prime factorization of the number.
From there, I can make a permutation of each subset of the factors, multiplied by the remaining factors at that iteration.
So if you take a number like 24, you get
2 * 2 * 2 * 3 // prime factorization
a b c d
// round 1
2 * (2 * 2 * 3) a * bcd
2 * (2 * 2 * 3) b * acd (removed for being dup)
2 * (2 * 2 * 3) c * abd (removed for being dup)
3 * (2 * 2 * 2) d * abc
Repeat for all "rounds" (round being the number of factors in the first number of the multiplication), removing duplicates as they come up.
So you end up with something like
// assume we have the prime factorization
// and a partition set to add to
for(int i = 1; i < factors.size; i++) {
for(List<int> subset : factors.permutate(2)) {
List<int> otherSubset = factors.copy().remove(subset);
int subsetTotal = 1;
for(int p : subset) subsetTotal *= p;
int otherSubsetTotal = 1;
for(int p : otherSubset) otherSubsetTotal *= p;
// assume your partition excludes if it's a duplicate
partition.add(new FactorSet(subsetTotal,otherSubsetTotal));
}
}
Of course, the first thing to do is find the prime factorisation of the number, like glowcoder said. Say
n = p^a * q^b * r^c * ...
Then
find the multiplicative partitions of m = n / p^a
for 0 <= k <= a, find the multiplicative partitions of p^k, which is equivalent to finding the additive partitions of k
for each multiplicative partition of m, find all distinct ways to distribute a-k factors p among the factors
combine results of 2. and 3.
It is convenient to treat the multiplicative partitions as lists (or sets) of (divisor, multiplicity) pairs to avoid producing duplicates.
I've written the code in Haskell because it's the most convenient and concise of the languages I know for this sort of thing:
module MultiPart (multiplicativePartitions) where
import Data.List (sort)
import Math.NumberTheory.Primes (factorise)
import Control.Arrow (first)
multiplicativePartitions :: Integer -> [[Integer]]
multiplicativePartitions n
| n < 1 = []
| n == 1 = [[]]
| otherwise = map ((>>= uncurry (flip replicate)) . sort) . pfPartitions $ factorise n
additivePartitions :: Int -> [[(Int,Int)]]
additivePartitions 0 = [[]]
additivePartitions n
| n < 0 = []
| otherwise = aParts n n
where
aParts :: Int -> Int -> [[(Int,Int)]]
aParts 0 _ = [[]]
aParts 1 m = [[(1,m)]]
aParts k m = withK ++ aParts (k-1) m
where
withK = do
let q = m `quot` k
j <- [q,q-1 .. 1]
[(k,j):prt | let r = m - j*k, prt <- aParts (min (k-1) r) r]
countedPartitions :: Int -> Int -> [[(Int,Int)]]
countedPartitions 0 count = [[(0,count)]]
countedPartitions quant count = cbParts quant quant count
where
prep _ 0 = id
prep m j = ((m,j):)
cbParts :: Int -> Int -> Int -> [[(Int,Int)]]
cbParts q 0 c
| q == 0 = if c == 0 then [[]] else [[(0,c)]]
| otherwise = error "Oops"
cbParts q 1 c
| c < q = [] -- should never happen
| c == q = [[(1,c)]]
| otherwise = [[(1,q),(0,c-q)]]
cbParts q m c = do
let lo = max 0 $ q - c*(m-1)
hi = q `quot` m
j <- [lo .. hi]
let r = q - j*m
m' = min (m-1) r
map (prep m j) $ cbParts r m' (c-j)
primePowerPartitions :: Integer -> Int -> [[(Integer,Int)]]
primePowerPartitions p e = map (map (first (p^))) $ additivePartitions e
distOne :: Integer -> Int -> Integer -> Int -> [[(Integer,Int)]]
distOne _ 0 d k = [[(d,k)]]
distOne p e d k = do
cap <- countedPartitions e k
return $ [(p^i*d,m) | (i,m) <- cap]
distribute :: Integer -> Int -> [(Integer,Int)] -> [[(Integer,Int)]]
distribute _ 0 xs = [xs]
distribute p e [(d,k)] = distOne p e d k
distribute p e ((d,k):dks) = do
j <- [0 .. e]
dps <- distOne p j d k
ys <- distribute p (e-j) dks
return $ dps ++ ys
distribute _ _ [] = []
pfPartitions :: [(Integer,Int)] -> [[(Integer,Int)]]
pfPartitions [] = [[]]
pfPartitions [(p,e)] = primePowerPartitions p e
pfPartitions ((p,e):pps) = do
cop <- pfPartitions pps
k <- [0 .. e]
ppp <- primePowerPartitions p k
mix <- distribute p (e-k) cop
return (ppp ++ mix)
It's not particularly optimised, but it does the job.
Some times and results:
Prelude MultiPart> length $ multiplicativePartitions $ 10^10
59521
(0.03 secs, 53535264 bytes)
Prelude MultiPart> length $ multiplicativePartitions $ 10^11
151958
(0.11 secs, 125850200 bytes)
Prelude MultiPart> length $ multiplicativePartitions $ 10^12
379693
(0.26 secs, 296844616 bytes)
Prelude MultiPart> length $ multiplicativePartitions $ product [2 .. 10]
70520
(0.07 secs, 72786128 bytes)
Prelude MultiPart> length $ multiplicativePartitions $ product [2 .. 11]
425240
(0.36 secs, 460094808 bytes)
Prelude MultiPart> length $ multiplicativePartitions $ product [2 .. 12]
2787810
(2.06 secs, 2572962320 bytes)
The 10^k are of course particularly easy because there are only two primes involved (but squarefree numbers are still easier), the factorials get slow earlier. I think by careful organisation of the order and choice of better data structures than lists, there's quite a bit to be gained (probably one should sort the prime factors by exponent, but I don't know whether one should start with the highest exponents or the lowest).
Why dont you find all the numbers that can divide the number and then you find permutations of the numbers that multiplications will add up to the number?
Finding all numbers that can divide your number takes O(n).
Then you can permute this set to find all possible sets that multiplication of this set will give you the number.
Once you find set of all possible numbers that divide the original number, then you can do dynamic programming on them to find the set of numbers that multiplying them will give you the original number.
If you have 5 distinct numbers, how many comparisons at most do you need to sort this using merge sort?
What is stopping you from coding a merge sort, keeping a counter for the number of comparisons in it, and trying it out on all permutations of [0,1,2,3,4]?
I find the question interesting, so I decided to explore it thoroughly (with a little experimentation in Python).
I downloaded mergesort.py from here and modified it to add a cmp argument for a comparator function. Then:
import collections
import itertools
import mergesort
import sys
class CountingComparator(object):
def __init__(self):
self.count = 0
def __call__(self, a, b):
self.count += 1
return cmp(a, b)
ms_histo = collections.defaultdict(int)
for perm in itertools.permutations(range(int(sys.argv[1]))):
cc = CountingComparator()
lperm = list(perm)
mergesort.mergesort(lperm, cmp=cc)
ms_histo[cc.count] += 1
for c in sorted(ms_histo):
print "%d %2d" % (c, ms_histo[c])
The resulting simple histogram (starting with a length of 4, as I did for developing and debugging this) is:
4 8
5 16
For the problem as posted, with a length of 5 instead of 4, I get:
5 4
6 20
7 48
8 48
and with a length of 6 (and a wider format;-):
7 8
8 56
9 176
10 288
11 192
Finally, with a length of 7 (and even wider format;-):
9 16
10 128
11 480
12 1216
13 1920
14 1280
Surely some perfectly regular combinatorial formula lurks here, but I'm finding it difficult to gauge what it might be, either analytically or by poring over the numbers. Anybody's got suggestions?
When merge-sorting two lists of length L1 and L2, I suppose the worst case number of comparisons is L1+L2-1.
Initially you have five 1-long lists.
You can merge two pairs of lists with 2 comparisons, resulting in lists of length 2,2 and 1.
Then you can merge a 2 and 1 long list with at most another 1+2-1 = 2 comparisons, yielding a 2 and 3 long list.
Finally you merge these lists with at most 2+3-1 = 4 comparisons.
So I guess the answer is 8.
This sequence of numbers results in the above:
[2], [4], [1], [3], [5] -> [2,4], [1,3], [5] -> [2,4], [1,3,5] -> [1,2,3,4,5]
Edit:
Here is a naive Erlang implementation. Based on this, the number of comparisons is 5,6,7 or 8 for permutations of 1..5.
-module(mergesort).
-compile(export_all).
test() ->
lists:sort([{sort(L),L} || L <- permutations()]).
sort([]) -> {0, []};
sort([_] = L) -> {0, L};
sort(L) ->
{L1, L2} = lists:split(length(L) div 2, L),
{C1, SL1} = sort(L1), {C2, SL2} = sort(L2),
{C3, RL} = merge(SL1, SL2, [], 0),
{C1+C2+C3, RL}.
merge([], L2, Merged, Comps) -> {Comps, Merged ++ L2};
merge(L1, [], Merged, Comps) -> {Comps, Merged ++ L1};
merge([H1|T1], [H2|_] = L2, Merged, Comps) when H1 < H2 -> merge(T1, L2, Merged ++[H1], Comps + 1);
merge(L1, [H2|T2], Merged, Comps) -> merge(L1, T2, Merged ++[H2], Comps + 1).
permutations() ->
L = lists:seq(1,5),
[[A,B,C,D,E] || A <- L, B <- L, C <- L, D <- L, E <- L, A =/= B, A =/= C, A =/= D, A =/= E, B =/= C, B =/= D, B =/= E, C =/= D, C =/= E, D =/= E].
http://www.sorting-algorithms.com/
According to Wikipedia: In the worst case, merge sort does an amount of comparisons equal to or slightly smaller than (n ⌈lg n⌉ - 2^⌈lg n⌉ + 1)
For just five distinct numbers to sort, the maximum number of comparisons you can have is 8 and minimum number of comparisons is 7. Here's why:-
Suppose the array is a,b,c,d,e
divide recursively: a,b,c and d,e
divide recursively: a,b&c and d&e
divide recursively: a&b & c and d&e
Now, merging which will require comparison-
a & b : one comparison to form a,b
a,b & c : two comparisons to form a,b,c
d & e : one comparison to form d,e
a,b,c and d,e : four comparison in worst case or three comparisons id d is the largest element of array to form a,b,c,d,e
So, the total number of comparisons will be eight in worst case and seven in the best case.
Locked. This question and its answers are locked because the question is off-topic but has historical significance. It is not currently accepting new answers or interactions.
I just finished participating in the 2009 ACM ICPC Programming Conest in the Latinamerican Finals. These questions were for Brazil, Bolivia, Chile, etc.
My team and I could only finish two questions out of the eleven (not bad I think for the first try).
Here's one we could finish. I'm curious to seeing any variations to the code. The question in full: ps: These questions can also be found on the official ICPC website available to everyone.
In the land of ACM ruled a greeat king who became obsessed with order. The kingdom had a rectangular form, and the king divided the territory into a grid of small rectangular counties. Before dying the king distributed the counties among his sons.
The king was unaware of the rivalries between his sons: The first heir hated the second but not the rest, the second hated the third but not the rest, and so on...Finally, the last heir hated the first heir, but not the other heirs.
As soon as the king died, the strange rivaly among the King's sons sparked off a generalized war in the kingdom. Attacks only took place between pairs of adjacent counties (adjacent counties are those that share one vertical or horizontal border). A county X attacked an adjacent county Y whenever X hated Y. The attacked county was always conquered. All attacks where carried out simultanously and a set of simultanous attacks was called a battle. After a certain number of battles, the surviving sons made a truce and never battled again.
For example if the king had three sons, named 0, 1 and 2, the figure below shows what happens in the first battle for a given initial land distribution:
INPUT
The input contains several test cases. The first line of a test case contains four integers, N, R, C and K.
N - The number of heirs (2 <= N <= 100)
R and C - The dimensions of the land. (2 <= R,C <= 100)
K - Number of battles that are going to take place. (1 <= K <= 100)
Heirs are identified by sequential integers starting from zero. Each of the next R lines contains C integers HeirIdentificationNumber (saying what heir owns this land) separated by single spaces. This is to layout the initial land.
The last test case is a line separated by four zeroes separated by single spaces. (To exit the program so to speak)
Output
For each test case your program must print R lines with C integers each, separated by single spaces in the same format as the input, representing the land distribution after all battles.
Sample Input: Sample Output:
3 4 4 3 2 2 2 0
0 1 2 0 2 1 0 1
1 0 2 0 2 2 2 0
0 1 2 0 0 2 0 0
0 1 2 2
Another example:
Sample Input: Sample Output:
4 2 3 4 1 0 3
1 0 3 2 1 2
2 1 2
Perl, 233 char
{$_=<>;($~,$R,$C,$K)=split;if($~){#A=map{$_=<>;split}1..$R;$x=0,
#A=map{$r=0;for$d(-$C,$C,1,-1){$r|=($y=$x+$d)>=0&$y<#A&1==($_-$A[$y])%$~
if($p=(1+$x)%$C)>1||1-$d-2*$p}$x++;($_-$r)%$~}#A
while$K--;print"#a\n"while#a=splice#A,0,$C;redo}}
The map is held in a one-dimensional array. This is less elegant than the two-dimensional solution, but it is also shorter. Contains the idiom #A=map{...}#A where all the fighting goes on inside the braces.
Python (420 characters)
I haven't played with code golf puzzles in a while, so I'm sure I missed a few things:
import sys
H,R,C,B=map(int,raw_input().split())
M=(1,0), (0,1),(-1, 0),(0,-1)
l=[map(int,r.split())for r in sys.stdin]
n=[r[:]for r in l[:]]
def D(r,c):
x=l[r][c]
a=[l[r+mr][c+mc]for mr,mc in M if 0<=r+mr<R and 0<=c+mc<C]
if x==0and H-1in a:n[r][c]=H-1
elif x-1in a:n[r][c]=x-1
else:n[r][c]=x
G=range
for i in G(B):
for r in G(R):
for c in G(C):D(r,c)
l=[r[:] for r in n[:]]
for r in l:print' '.join(map(str,r))
Lua, 291 Characters
g=loadstring("return io.read('*n')")repeat n=g()r=g()c=g()k=g()l={}c=c+1 for
i=0,k do w={}for x=1,r*c do a=l[x]and(l[x]+n-1)%n w[x]=i==0 and x%c~=0 and
g()or(l[x-1]==a or l[x+1]==a or l[x+c]==a or l[x-c]==a)and a or
l[x]io.write(i~=k and""or x%c==0 and"\n"or w[x].." ")end l=w end until n==0
F#, 675 chars
let R()=System.Console.ReadLine().Split([|' '|])|>Array.map int
let B(a:int[][]) r c g=
let n=Array.init r (fun i->Array.copy a.[i])
for i in 1..r-2 do for j in 1..c-2 do
let e=a.[i].[j]-1
let e=if -1=e then g else e
if a.[i-1].[j]=e||a.[i+1].[j]=e||a.[i].[j-1]=e||a.[i].[j+1]=e then
n.[i].[j]<-e
n
let mutable n,r,c,k=0,0,0,0
while(n,r,c,k)<>(0,2,2,0)do
let i=R()
n<-i.[0]
r<-i.[1]+2
c<-i.[2]+2
k<-i.[3]
let mutable a=Array.init r (fun i->
if i=0||i=r-1 then Array.create c -2 else[|yield -2;yield!R();yield -2|])
for j in 1..k do a<-B a r c (n-1)
for i in 1..r-2 do
for j in 1..c-2 do
printf "%d" a.[i].[j]
printfn ""
Make the array big enough to put an extra border of "-2" around the outside - this way can look left/up/right/down without worrying about out-of-bounds exceptions.
B() is the battle function; it clones the array-of-arrays and computes the next layout. For each square, see if up/down/left/right is the guy who hates you (enemy 'e'), if so, he takes you over.
The main while loop just reads input, runs k iterations of battle, and prints output as per the spec.
Input:
3 4 4 3
0 1 2 0
1 0 2 0
0 1 2 0
0 1 2 2
4 2 3 4
1 0 3
2 1 2
0 0 0 0
Output:
2220
2101
2220
0200
103
212
Python 2.6, 383 376 Characters
This code is inspired by Steve Losh' answer:
import sys
A=range
l=lambda:map(int,raw_input().split())
def x(N,R,C,K):
if not N:return
m=[l()for _ in A(R)];n=[r[:]for r in m]
def u(r,c):z=m[r][c];n[r][c]=(z-((z-1)%N in[m[r+s][c+d]for s,d in(-1,0),(1,0),(0,-1),(0,1)if 0<=r+s<R and 0<=c+d<C]))%N
for i in A(K):[u(r,c)for r in A(R)for c in A(C)];m=[r[:]for r in n]
for r in m:print' '.join(map(str,r))
x(*l())
x(*l())
Haskell (GHC 6.8.2), 570 446 415 413 388 Characters
Minimized:
import Monad
import Array
import List
f=map
d=getLine>>=return.f read.words
h m k=k//(f(\(a#(i,j),e)->(a,maybe e id(find(==mod(e-1)m)$f(k!)$filter(inRange$bounds k)[(i-1,j),(i+1,j),(i,j-1),(i,j+1)])))$assocs k)
main=do[n,r,c,k]<-d;when(n>0)$do g<-mapM(const d)[1..r];mapM_(\i->putStrLn$unwords$take c$drop(i*c)$f show$elems$(iterate(h n)$listArray((1,1),(r,c))$concat g)!!k)[0..r-1];main
The code above is based on the (hopefully readable) version below. Perhaps the most significant difference with sth's answer is that this code uses Data.Array.IArray instead of nested lists.
import Control.Monad
import Data.Array.IArray
import Data.List
type Index = (Int, Int)
type Heir = Int
type Kingdom = Array Index Heir
-- Given the dimensions of a kingdom and a county, return its neighbors.
neighbors :: (Index, Index) -> Index -> [Index]
neighbors dim (i, j) =
filter (inRange dim) [(i - 1, j), (i + 1, j), (i, j - 1), (i, j + 1)]
-- Given the first non-Heir and a Kingdom, calculate the next iteration.
iter :: Heir -> Kingdom -> Kingdom
iter m k = k // (
map (\(i, e) -> (i, maybe e id (find (== mod (e - 1) m) $
map (k !) $ neighbors (bounds k) i))) $
assocs k)
-- Read a line integers from stdin.
readLine :: IO [Int]
readLine = getLine >>= return . map read . words
-- Print the given kingdom, assuming the specified number of rows and columns.
printKingdom :: Int -> Int -> Kingdom -> IO ()
printKingdom r c k =
mapM_ (\i -> putStrLn $ unwords $ take c $ drop (i * c) $ map show $ elems k)
[0..r-1]
main :: IO ()
main = do
[n, r, c, k] <- readLine -- read number of heirs, rows, columns and iters
when (n > 0) $ do -- observe that 0 heirs implies [0, 0, 0, 0]
g <- sequence $ replicate r readLine -- read initial state of the kingdom
printKingdom r c $ -- print kingdom after k iterations
(iterate (iter n) $ listArray ((1, 1), (r, c)) $ concat g) !! k
main -- handle next test case
AWK - 245
A bit late, but nonetheless... Data in a 1-D array. Using a 2-D array the solution is about 30 chars longer.
NR<2{N=$1;R=$2;C=$3;K=$4;M=0}NR>1{for(i=0;i++<NF;)X[M++]=$i}END{for(k=0;k++<K;){
for(i=0;i<M;){Y[i++]=X[i-(i%C>0)]-(b=(N-1+X[i])%N)&&X[i+((i+1)%C>0)]-b&&X[i-C]-b
&&[i+C]-b?X[i]:b}for(i in Y)X[i]=Y[i]}for(i=0;i<M;)printf"%s%d",i%C?" ":"\n",
X[i++]}