I have a text file like so:
{fruit, [apple,banana,kiwi]}.
{car, [estate,hatchback]}.
{tree, [ebony,pine,ask,birch]}.
{planet, [earth]}.
How can I read it into a map or any other data structure in Erlang (to further iterate over each key and its respective value) and finally print the map?
$ cat > things.txt
{fruit, [apple,banana,kiwi]}.
{car, [estate,hatchback]}.
{tree, [ebony,pine,ask,birch]}.
{planet, [earth]}.
$ erl
Erlang/OTP 20 [erts-9.3] [source] [64-bit] [smp:4:4] [ds:4:4:10] [async-threads:10] [hipe] [kernel-poll:false]
Eshell V9.3 (abort with ^G)
1> {ok, L} = file:consult("things.txt").
{ok,[{fruit,[apple,banana,kiwi]},
{car,[estate,hatchback]},
{tree,[ebony,pine,ask,birch]},
{planet,[earth]}]}
2> maps:from_list(L).
#{car => [estate,hatchback],
fruit => [apple,banana,kiwi],
planet => [earth],
tree => [ebony,pine,ask,birch]}
This one is works for me
-module(test).
-export([start/0, scan_string/1]).
start() ->
{ok, File} = file:open("Newfile.txt",[read]),
{ok, List} = file:read(File,1024 * 1024),
KeyVal = scan_string(List),
F = fun({K,V}, Acc) -> maps:put(K, V, Acc) end,
lists:foldl(F, #{}, KeyVal).
scan_string(TermString) ->
{_, Strings} = lists:foldl(fun break_terms/2, {"", []}, TermString),
Tokens = [T || {ok, T, _} <- lists:map(fun erl_scan:string/1, Strings)],
AbsForms = [A || {ok, A} <- lists:map(fun erl_parse:parse_exprs/1, Tokens)],
[V || {value, V, _} <- lists:map(fun eval_terms/1, AbsForms)].
break_terms($., {String, Lines}) ->
Line = lists:reverse([$. | String]),
{"", [Line | Lines]};
break_terms(Char, {String, Lines}) ->
{[Char | String], Lines}.
eval_terms(Abstract) ->
erl_eval:exprs(Abstract, erl_eval:new_bindings()).
Newfile.txt =
{fruit, [apple,banana,kiwi]}.
{car, [estate,hatchback]}.
{tree, [ebony,pine,ask,birch]}.
{planet, [earth]}.
Shell =
Eshell V9.3.1 (abort with ^G)
1> c(test).
{ok,test}
2> test:start().
#{car => [estate,hatchback],
fruit => [apple,banana,kiwi],
tree => [ebony,pine,ask,birch]}
3>
Related
I am learning Haskell, and as a task for myself I was trying to implement a Universal Machine from ICFP Contest 2006. I came up with a code, which, at a first glance, seems to be working. However, when I try to execute any application for that Universal Machine provided on the contest's website (e.g. sandmark.umz), my implementation is too slow to actually run anything. Self-check did not finish in a couple of hours, and I had to kill the process. So, I am clearly doing something wrong, I just don't know what.
I have tried to use Haskell's profiler, but I couldn't make any sense out of those numbers as well. Garbage collection doesn't seem to be taking a lot of time (3 seconds out of 173 seconds of a sample). However, total allocated memory during those 173 seconds was almost 6 GB, while the maximum heap size was 13 MB.
Could you help me understand, what is wrong with my code? I know that the amount of code is quite large, but I am not sure how to come up with a minimum reproducible example in my case, when I don't really know what is relevant, and what is not. Thank you.
module Main where
import System.Environment (getArgs)
import System.Exit (exitSuccess)
import System.IO (hPutStrLn, stderr)
import System.IO.Error (catchIOError)
import Control.Monad (when)
import Control.Monad.Loops (iterateM_)
import Data.Array.IO (IOUArray, newArray, newListArray, readArray, writeArray, mapArray)
import Data.Bits
import Data.Binary.Get (getWord32be, runGet, isEmpty, Get)
import Data.Char (chr, ord)
import Data.Word (Word32)
import Data.Maybe (fromJust)
import qualified Data.IntMap.Strict as M
import qualified Data.ByteString.Lazy as B
import qualified Data.IntSet as IntSet
data UMState = UMState {
getFinger :: Word32,
getRegisters :: IOUArray Int Word32,
getArrays :: M.IntMap (IOUArray Word32 Word32),
getFreeIds :: [Int],
getMaxId :: Int,
getCopiedPlatters :: IntSet.IntSet
}
getOperation :: Word32 -> Int
getOperation x = fromIntegral $ (x `shiftR` 28) .&. 15
getRegisterIds :: Word32 -> (Int, Int, Int)
getRegisterIds x = (fromIntegral $ (x `shiftR` 6) .&. 7, fromIntegral $ (x `shiftR` 3) .&. 7, fromIntegral $ x .&. 7)
getOrthography :: Word32 -> (Int, Word32)
getOrthography x = (fromIntegral $ (x `shiftR` 25) .&. 7, x .&. 33554431)
setFinger :: UMState -> Word32 -> UMState
setFinger (UMState {
getFinger = _,
getRegisters = regs,
getArrays = arr,
getFreeIds = fids,
getMaxId = mid,
getCopiedPlatters = cp
}) f' = UMState {
getFinger = f',
getRegisters = regs,
getArrays = arr,
getFreeIds = fids,
getMaxId = mid,
getCopiedPlatters = cp
}
removePlatter :: UMState -> Int -> UMState
removePlatter (UMState {
getFinger = f,
getRegisters = regs,
getArrays = arr,
getFreeIds = fids,
getMaxId = mid,
getCopiedPlatters = cp
}) pid = UMState {
getFinger = f,
getRegisters = regs,
getArrays = M.delete pid arr,
getFreeIds = (pid:fids),
getMaxId = mid,
getCopiedPlatters = cp
}
insertPlatter :: UMState -> Int -> IOUArray Word32 Word32 -> UMState
insertPlatter (UMState {
getFinger = f,
getRegisters = regs,
getArrays = arr,
getFreeIds = fids#(hfid:tfids),
getMaxId = mid,
getCopiedPlatters = cp
}) pid platter = UMState {
getFinger = f,
getRegisters = regs,
getArrays = M.insert pid platter arr,
getFreeIds = if pid == hfid then tfids else fids,
getMaxId = max mid pid,
getCopiedPlatters = cp
}
insertPlatter (UMState {
getFinger = f,
getRegisters = regs,
getArrays = arr,
getFreeIds = [],
getMaxId = mid,
getCopiedPlatters = cp
}) pid platter = UMState {
getFinger = f,
getRegisters = regs,
getArrays = M.insert pid platter arr,
getFreeIds = [],
getMaxId = max mid pid,
getCopiedPlatters = cp
}
setCopiedPlatters :: UMState -> IntSet.IntSet -> UMState
setCopiedPlatters (UMState {
getFinger = f,
getRegisters = regs,
getArrays = arr,
getFreeIds = fids,
getMaxId = mid,
getCopiedPlatters = _
}) copied' = UMState {
getFinger = f,
getRegisters = regs,
getArrays = arr,
getFreeIds = fids,
getMaxId = mid,
getCopiedPlatters = copied'
}
main = do
args <- getArgs
fileName <- parseArgs $ filter (\arg -> arg /= "--") args
platters <- B.readFile fileName
array0 <- listToArray (runGet readPlatters platters)
regs <- (newArray (0, 7) 0 :: IO (IOUArray Int Word32))
let initState = (UMState {
getFinger = 0,
getRegisters = regs,
getArrays = M.insert 0 array0 M.empty,
getFreeIds = [],
getMaxId = 0,
getCopiedPlatters = IntSet.empty
})
in iterateM_ spinCycle initState
parseArgs :: [String] -> IO (String)
parseArgs [arg] = return arg
parseArgs args = fail $ "Exactly one argument expected. Found: " ++ (show args)
readPlatters :: Get [Word32]
readPlatters = do
empty <- isEmpty
if empty
then return []
else do
platter <- getWord32be
theRest <- readPlatters
return (platter:theRest)
listToArray :: [Word32] -> IO (IOUArray Word32 Word32)
listToArray lst = newListArray (fromIntegral 0, fromIntegral (length lst) - 1) lst
spinCycle :: UMState -> IO (UMState)
spinCycle state = do
platter <- readArray (fromJust (M.lookup 0 (getArrays state))) (getFinger state)
let state' = setFinger state $ getFinger state + 1
(aId, bId, cId) = getRegisterIds platter
regs = getRegisters state'
arrays = getArrays state' in (
case (getOperation platter) of
0 -> do
runConditionalMove aId bId cId regs
return state'
1 -> do
runArrayIndex aId bId cId regs arrays
return state'
2 -> runArrayAmendment aId bId cId state'
3 -> do
runAddition aId bId cId regs
return state'
4 -> do
runMultiplication aId bId cId regs
return state'
5 -> do
runDivision aId bId cId regs
return state'
6 -> do
runNand aId bId cId regs
return state'
7 -> runHalt
8 -> runAllocation bId cId state'
9 -> runAbandonment cId state'
10 -> do
runOutput cId regs
return state'
11 -> do
runInput cId regs
return state'
12 -> runLoadProgram bId cId state'
13 -> do
let (reg, val) = getOrthography platter
in (runOrthography reg val regs)
return state'
)
-- #0. Conditional Move.
runConditionalMove :: Int -> Int -> Int -> IOUArray Int Word32 -> IO ()
runConditionalMove a b c regs = do
hPutStrLn stderr ("conditionalMove " ++ (show a) ++ " " ++ (show b) ++ " " ++ (show c))
cRead <- readArray regs c
when (cRead /= 0) $ do
bRead <- readArray regs b
writeArray regs a bRead
-- #1. Array Index.
runArrayIndex :: Int -> Int -> Int -> IOUArray Int Word32 -> M.IntMap (IOUArray Word32 Word32) -> IO ()
runArrayIndex a b c regs arrays = do
hPutStrLn stderr ("arrayIndex " ++ (show a) ++ " " ++ (show b) ++ " " ++ (show c))
bRead <- readArray regs b
cRead <- readArray regs c
val <- readArray (fromJust (M.lookup (fromIntegral bRead) arrays)) cRead
writeArray regs a val
-- #2. Array Amendment.
runArrayAmendment :: Int -> Int -> Int -> UMState -> IO (UMState)
runArrayAmendment a b c state = do
hPutStrLn stderr ("arrayAmendment " ++ (show a) ++ " " ++ (show b) ++ " " ++ (show c))
aRead <- readArray (getRegisters state) a
bRead <- readArray (getRegisters state) b
cRead <- readArray (getRegisters state) c
stateToWrite <- if IntSet.member (fromIntegral aRead) (getCopiedPlatters state) then (do
pCopy <- mapArray id (fromJust (M.lookup (fromIntegral aRead) (getArrays state)))
let state' = insertPlatter state (fromIntegral aRead) pCopy
state'' = setCopiedPlatters state' $ IntSet.delete (fromIntegral aRead) (getCopiedPlatters state')
in return state''
) else return state
writeArray (fromJust (M.lookup (fromIntegral aRead) (getArrays stateToWrite))) bRead cRead
return stateToWrite
-- #3. Addition.
runAddition :: Int -> Int -> Int -> IOUArray Int Word32 -> IO ()
runAddition a b c regs = do
hPutStrLn stderr ("addition " ++ (show a) ++ " " ++ (show b) ++ " " ++ (show c))
bRead <- readArray regs b
cRead <- readArray regs c
writeArray regs a (bRead + cRead)
-- #4. Multiplication.
runMultiplication :: Int -> Int -> Int -> IOUArray Int Word32 -> IO ()
runMultiplication a b c regs = do
hPutStrLn stderr ("multiplication " ++ (show a) ++ " " ++ (show b) ++ " " ++ (show c))
bRead <- readArray regs b
cRead <- readArray regs c
writeArray regs a (bRead * cRead)
-- #5. Division.
runDivision :: Int -> Int -> Int -> IOUArray Int Word32 -> IO ()
runDivision a b c regs = do
hPutStrLn stderr ("division " ++ (show a) ++ " " ++ (show b) ++ " " ++ (show c))
bRead <- readArray regs b
cRead <- readArray regs c
writeArray regs a (bRead `div` cRead)
-- #6. Not-And.
runNand :: Int -> Int -> Int -> IOUArray Int Word32 -> IO ()
runNand a b c regs = do
hPutStrLn stderr ("nand " ++ (show a) ++ " " ++ (show b) ++ " " ++ (show c))
bRead <- readArray regs b
cRead <- readArray regs c
writeArray regs a (complement $ bRead .&. cRead)
-- #7. Halt.
runHalt = exitSuccess :: IO (UMState)
-- #8. Allocation.
runAllocation :: Int -> Int -> UMState -> IO (UMState)
runAllocation b c state = do
hPutStrLn stderr ("allocation " ++ (show b) ++ " " ++ (show c))
cRead <- readArray (getRegisters state) c
pArray <- (newArray (0, cRead) 0 :: IO (IOUArray Word32 Word32))
(state', newId) <-
case (getFreeIds state) of
(freeId:_) -> return (insertPlatter state freeId pArray, freeId)
[] -> let maxId' = getMaxId state + 1 in return (insertPlatter state maxId' pArray, maxId')
writeArray (getRegisters state') b (fromIntegral newId)
return state'
-- #9. Abandonment.
runAbandonment :: Int -> UMState -> IO (UMState)
runAbandonment c state = do
hPutStrLn stderr ("abandonment " ++ (show c))
cRead <- readArray (getRegisters state) c
return (removePlatter state $ fromIntegral cRead)
-- #10. Output.
runOutput :: Int -> IOUArray Int Word32 -> IO ()
runOutput c regs = do
cRead <- readArray regs c
when (cRead < 256) $ putChar . chr . fromIntegral $ cRead
-- #11. Input.
runInput :: Int -> IOUArray Int Word32 -> IO ()
runInput c regs = do
cRead <- getChar `catchIOError` (\_ -> return $ chr 255)
writeArray regs c (fromIntegral $ ord cRead)
-- #12. Load Program.
runLoadProgram :: Int -> Int -> UMState -> IO (UMState)
runLoadProgram b c state = do
hPutStrLn stderr ("loadProgram " ++ (show b) ++ " " ++ (show c))
bRead <- readArray (getRegisters state) b
cRead <- readArray (getRegisters state) c
let bReadInt = fromIntegral bRead
pCopy = fromJust (M.lookup bReadInt (getArrays state))
copied = IntSet.insert 0 (getCopiedPlatters state)
copied' = IntSet.insert bReadInt copied
state' = insertPlatter state 0 pCopy
state'' = setFinger state' cRead
state''' = setCopiedPlatters state'' copied'
in return state'''
-- #13. Orthography.
runOrthography :: Int -> Word32 -> IOUArray Int Word32 -> IO ()
runOrthography reg val regs = writeArray regs reg val
Total allocation of 3 gigabytes for a Haskell programming running for 176 seconds is miniscule. Most Haskell programs allocate 3-6 gigabytes per second for their entire runtime. In your case, much of the program is running in tight, allocation-free loops (generally a good thing when you're trying to write a fast program), which may explain the small amount of allocation. The small proportion of time spent garbage collecting is also a good sign.
I tested your program on sandmark.umz andcodex.umz, built with -O2 and no profiling.
I believe the main problem is that the hPutStrLn logging lines are generating tons of output, so your universal machine is spending all its time writing logs.
Comment out all the hPutStrLn lines, and SANDmark prints a line every few seconds. I have no idea how fast it's supposed to be, but it's certainly running.
For Codex, it completes the self-check succeeded in a few seconds and accepts a 32-character key. If you enter the wrong key, it prints "wrong key". If you enter the right key, it prints "decrypting..." At this point, it seems to freeze up, so I suspect your implementation is too slow, but not nearly as slow as you were reporting.
Note that you may find it helpful to turn off buffering on stdin and stdout at the start of main:
main = do
hSetBuffering stdin NoBuffering
hSetBuffering stdout NoBuffering
...
so that the getChar and putChar-based I/O operate immediately. This isn't strictly necessary, but might help avoid apparent lockups that are actually just buffering issues.
Should one expect performance differences between these two emptys, or is it merely a matter of stylistic preference?
foo list = case list of
[] -> True
(_ : _) -> False
bar list = case list of
(_ : _) -> False
_ -> True
In general you should not expect performance to change predictably between trivial fiddling around with patterns like what you're asking about, and can often expect the generated code to be identical.
But the way to actually check is to look at core and or benchmark with criterion. In this case the generated code is the same, and indeed GHC seems to actually combine them:
I compiled the snippet above with
ghc -Wall -O2 -ddump-to-file -ddump-simpl -dsuppress-module-prefixes -dsuppress-uniques -fforce-recomp YourCode.hs
And we see this core:
foo :: forall t. [t] -> Bool
[GblId,
Arity=1,
Caf=NoCafRefs,
Str=DmdType <S,1*U>,
Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
Tmpl= \ (# t) (list [Occ=Once!] :: [t]) ->
case list of _ [Occ=Dead] {
[] -> True;
: _ [Occ=Dead] _ [Occ=Dead] -> False
}}]
foo =
\ (# t) (list :: [t]) ->
case list of _ [Occ=Dead] {
[] -> True;
: ds ds1 -> False
}
-- RHS size: {terms: 1, types: 0, coercions: 0}
bar :: forall t. [t] -> Bool
[GblId,
Arity=1,
Caf=NoCafRefs,
Str=DmdType <S,1*U>,
Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
Tmpl= \ (# t) (list [Occ=Once!] :: [t]) ->
case list of _ [Occ=Dead] {
[] -> True;
: _ [Occ=Dead] _ [Occ=Dead] -> False
}}]
bar = foo
I think the Tmpl stuff is the original implementation exposed for inlining in other modules, but I'm not certain.
This question already has an answer here:
GHC 7.10 generates slower code than older versions
(1 answer)
Closed 6 years ago.
I have following code. It costs 1s to run with argument 1000000, but it costs 5s to run if replace myEven with standard even function. I checked the code, the standard even function does exactly the same as * myEven *.
import Data.Word
import Data.List
import System.Environment
collatzNext :: Word32 -> Word32
collatzNext a = (if myEven a then a else 3*a+1) `div` 2
myEven :: (Integral a) => a -> Bool
myEven a = (a `rem` 2) == 0
collatzLen :: Word32 -> Int
collatzLen a0 = length $ takeWhile (/= 1) $ iterate collatzNext a0
main = do
[a0] <- getArgs
let max_a0 = (read a0)::Word32
print $ maximum $ map (\a0 -> (collatzLen a0, a0)) [1..max_a0]
If you add {-# NOINLINE myEven #-}, you'll get the same slowdown. The issue is that myEven is defined locally, so it's source is available to compiler, and it is inlined. All allocations and function call itself are eliminated:
Main.$wgo1 [InlPrag=[0], Occ=LoopBreaker]
:: GHC.Prim.Word# -> GHC.Prim.Int# -> GHC.Prim.Int#
[GblId, Arity=2, Caf=NoCafRefs, Str=DmdType <S,1*U><L,U>]
Main.$wgo1 =
\ (ww_s6n0 :: GHC.Prim.Word#) (ww1_s6n4 :: GHC.Prim.Int#) ->
case ww_s6n0 of wild_X2j {
__DEFAULT ->
case GHC.Prim.remWord# wild_X2j (__word 2) of _ [Occ=Dead] {
__DEFAULT ->
Main.$wgo1
(GHC.Prim.quotWord#
(GHC.Prim.narrow32Word#
(GHC.Prim.plusWord#
(GHC.Prim.narrow32Word# (GHC.Prim.timesWord# (__word 3) wild_X2j))
(__word 1)))
(__word 2))
(GHC.Prim.+# ww1_s6n4 1);
__word 0 ->
Main.$wgo1
(GHC.Prim.quotWord# wild_X2j (__word 2)) (GHC.Prim.+# ww1_s6n4 1)
};
__word 1 -> ww1_s6n4
}
But even is defined in other module and it is not marked as INLINE or INLINEABLE. As a result it is not inlined, and each call to even allocates boxed Word32:
Main.$wgo1 [InlPrag=[0], Occ=LoopBreaker]
:: GHC.Prim.Word# -> GHC.Prim.Int# -> GHC.Prim.Int#
[GblId, Arity=2, Str=DmdType <S,U><L,U>]
Main.$wgo1 =
\ (ww_s6mz :: GHC.Prim.Word#) (ww1_s6mD :: GHC.Prim.Int#) ->
case ww_s6mz of wild_X1W {
__DEFAULT ->
case even
# Word32 GHC.Word.$fIntegralWord32 (GHC.Word.W32# wild_X1W)
of _ [Occ=Dead] {
False ->
Main.$wgo1
(GHC.Prim.quotWord#
(GHC.Prim.narrow32Word#
(GHC.Prim.plusWord#
(GHC.Prim.narrow32Word# (GHC.Prim.timesWord# (__word 3) wild_X1W))
(__word 1)))
(__word 2))
(GHC.Prim.+# ww1_s6mD 1);
True ->
Main.$wgo1
(GHC.Prim.quotWord# wild_X1W (__word 2)) (GHC.Prim.+# ww1_s6mD 1)
};
__word 1 -> ww1_s6mD
}
Note that even is specialized for Int and Integer, but not for Word32, so the issue doesn't occurs if you use Int.
Will GHC transform an expression with intermediate values as efficiently as one without?
e.g.
main = print $ f ["aa", "bb", "cc"]
f x =
let a = map (map toUpper) x
b = filter (\z -> 'C' /= head z) a
c = foldl1 (++) b
in c
seems to have very different core output (with -ddump-simple) than with
f x = foldl1 (++) $ filter (\z -> 'C' /= head z) $ map (map toUpper) x
Could an expression with intermediate values take (significantly) longer to evaluate?
Linear use of intermediate let bindings is equivalent to putting (.) between the values.
GHC will fuse through such pipelines. You can see from the results of -ddump-simpl-stats
With let Bindings:
15 RuleFired
1 ++
1 Class op /=
1 Class op show
1 Class op showList
1 filter
1 fold/build
1 foldr/app
1 map
1 neChar#->case
3 unpack
3 unpack-list
Using a pipeline:
15 RuleFired
1 ++
1 Class op /=
1 Class op show
1 Class op showList
1 filter
1 fold/build
1 foldr/app
1 map
1 neChar#->case
3 unpack
3 unpack-list
And the same fused worker:
With let Bindings:
Main.main_go =
\ (ds_aAz :: [[GHC.Types.Char]]) ->
case ds_aAz of _ {
[] -> GHC.Types.[] # [GHC.Types.Char];
: y_aAE ys_aAF ->
case GHC.Base.map
# GHC.Types.Char # GHC.Types.Char GHC.Unicode.toUpper y_aAE
of wild1_azI {
[] ->
GHC.List.badHead
`cast` (UnsafeCo (forall a_azK. a_azK) [[GHC.Types.Char]]
:: (forall a_azK. a_azK) ~ [[GHC.Types.Char]]);
: x_azM ds1_azN ->
case x_azM of _ { GHC.Types.C# c2_aAa ->
case c2_aAa of _ {
__DEFAULT ->
GHC.Types.: # [GHC.Types.Char] wild1_azI (Main.main_go ys_aAF);
'C' -> Main.main_go ys_aAF
}
Pipeline:
Main.main_go =
\ (ds_aAA :: [[GHC.Types.Char]]) ->
case ds_aAA of _ {
[] -> GHC.Types.[] # [GHC.Types.Char];
: y_aAF ys_aAG ->
case GHC.Base.map
# GHC.Types.Char # GHC.Types.Char GHC.Unicode.toUpper y_aAF
of wild1_azB {
[] ->
GHC.List.badHead
`cast` (UnsafeCo (forall a_azD. a_azD) [[GHC.Types.Char]]
:: (forall a_azD. a_azD) ~ [[GHC.Types.Char]]);
: x_azF ds1_azG ->
case x_azF of _ { GHC.Types.C# c2_aA3 ->
case c2_aA3 of _ {
__DEFAULT ->
GHC.Types.: # [GHC.Types.Char] wild1_azB (Main.main_go ys_aAG);
'C' -> Main.main_go ys_aAG
}
}
Did you forget to compile with -O2 ?
This is my very first F# programme. I thought I would implement Conway's Game of Life as a first exercise.
Please help me understand why the following code has such terrible performance.
let GetNeighbours (p : int, w : int, h : int) : seq<int> =
let (f1, f2, f3, f4) = (p > w, p % w <> 1, p % w <> 0, p < w * (h - 1))
[
(p - w - 1, f1 && f2);
(p - w, f1);
(p - w + 1, f1 && f3);
(p - 1, f2);
(p + 1, f3);
(p + w - 1, f4 && f2);
(p + w, f4);
(p + w + 1, f4 && f3)
]
|> List.filter (fun (s, t) -> t)
|> List.map (fun (s, t) -> s)
|> Seq.cast
let rec Evolve (B : seq<int>, S : seq<int>, CC : seq<int>, g : int) : unit =
let w = 10
let h = 10
let OutputStr = (sprintf "Generation %d: %A" g CC) // LINE_MARKER_1
printfn "%s" OutputStr
let CCN = CC |> Seq.map (fun s -> (s, GetNeighbours (s, w, h)))
let Survivors =
CCN
|> Seq.map (fun (s, t) -> (s, t |> Seq.map (fun u -> (CC |> Seq.exists (fun v -> u = v)))))
|> Seq.map (fun (s, t) -> (s, t |> Seq.filter (fun u -> u)))
|> Seq.map (fun (s, t) -> (s, Seq.length t))
|> Seq.filter (fun (s, t) -> (S |> Seq.exists (fun u -> t = u)))
|> Seq.map (fun (s, t) -> s)
let NewBorns =
CCN
|> Seq.map (fun (s, t) -> t)
|> Seq.concat
|> Seq.filter (fun s -> not (CC |> Seq.exists (fun t -> t = s)))
|> Seq.groupBy (fun s -> s)
|> Seq.map (fun (s, t) -> (s, Seq.length t))
|> Seq.filter (fun (s, t) -> B |> Seq.exists (fun u -> u = t))
|> Seq.map (fun (s, t) -> s)
let NC = Seq.append Survivors NewBorns
let SWt = new System.Threading.SpinWait ()
SWt.SpinOnce ()
if System.Console.KeyAvailable then
match (System.Console.ReadKey ()).Key with
| System.ConsoleKey.Q -> ()
| _ -> Evolve (B, S, NC, (g + 1))
else
Evolve (B, S, NC, (g + 1))
let B = [3]
let S = [2; 3]
let IC = [4; 13; 14]
let g = 0
Evolve (B, S, IC, g)
The first five iterations, i.e. generations 0, 1, 2, 3, 4, happen without a problem. Then, after a brief pause of about 100 milliseconds, generation 5 is completed. But after that, the programme hangs at the line marked "LINE_MARKER_1," as revealed by breakpoints Visual Studio. It never reaches the printfn line.
The strange thing is, already by generation 2, the CC sequence in the function Evolve has already stabilised to the sequence [4; 13; 14; 3] so I see no reason why generation 6 should fail to evolve.
I understand that it is generally considered opprobrious to paste large segments of code and ask for help in debugging, but I don't know how to reduce this to a minimum working example. Any pointers that would help me debug would be gratefully acknowledged.
Thanks in advance for your help.
EDIT
I really believe that anyone wishing to help me may pretty much ignore the GetNeighbours function. I included it only for the sake of completeness.
The simplest way to fix your performance is by using Seq.cache:
let GetNeighbours (p : int, w : int, h : int) : seq<int> =
let (f1, f2, f3, f4) = (p > w, p % w <> 1, p % w <> 0, p < w * (h - 1))
[
(p - w - 1, f1 && f2);
(p - w, f1);
(p - w + 1, f1 && f3);
(p - 1, f2);
(p + 1, f3);
(p + w - 1, f4 && f2);
(p + w, f4);
(p + w + 1, f4 && f3)
]
|> List.filter (fun (s, t) -> t)
|> List.map (fun (s, t) -> s)
:> seq<_> // <<<<<<<<<<<<<<<<<<<<<<<< MINOR EDIT, avoid boxing
let rec Evolve (B : seq<int>, S : seq<int>, CC : seq<int>, g : int) : unit =
let w = 10
let h = 10
let OutputStr = (sprintf "Generation %d: %A" g CC) // LINE_MARKER_1
printfn "%s" OutputStr
let CCN =
CC
|> Seq.map (fun s -> (s, GetNeighbours (s, w, h)))
|> Seq.cache // <<<<<<<<<<<<<<<<<< EDIT
let Survivors =
CCN
|> Seq.map (fun (s, t) -> (s, t |> Seq.map (fun u -> (CC |> Seq.exists (fun v -> u = v)))))
|> Seq.map (fun (s, t) -> (s, t |> Seq.filter (fun u -> u)))
|> Seq.map (fun (s, t) -> (s, Seq.length t))
|> Seq.filter (fun (s, t) -> (S |> Seq.exists (fun u -> t = u)))
|> Seq.map (fun (s, t) -> s)
let NewBorns =
CCN
|> Seq.map (fun (s, t) -> t)
|> Seq.concat
|> Seq.filter (fun s -> not (CC |> Seq.exists (fun t -> t = s)))
|> Seq.groupBy (fun s -> s)
|> Seq.map (fun (s, t) -> (s, Seq.length t))
|> Seq.filter (fun (s, t) -> B |> Seq.exists (fun u -> u = t))
|> Seq.map (fun (s, t) -> s)
let NC =
Seq.append Survivors NewBorns
|> Seq.cache // <<<<<<<<<<<<<<<<<< EDIT
let SWt = new System.Threading.SpinWait ()
SWt.SpinOnce ()
if System.Console.KeyAvailable then
match (System.Console.ReadKey ()).Key with
| System.ConsoleKey.Q -> ()
| _ -> Evolve (B, S, NC, (g + 1))
else
Evolve (B, S, NC, (g + 1))
let B = [3]
let S = [2; 3]
let IC = [4; 13; 14]
let g = 0
Evolve (B, S, IC, g)
The big problem is not using Seq per se, the problem is using it correctly. By default sequences are not lazy, instead they define computations that are re-evaluated on every traversal. This means that unless you do something about it (such as Seq.cache), re-evaluating the sequence may screw up the algorithmic complexity of your program.
Your original program has exponential complexity. To see that, note that it doubles the number of traversed elements with each iteration.
Also note that with your style of programming using Seq operators followed by Seq.cache has a small advantage over using List or Array operators: this avoids allocating intermediate data structures, which reduces GC pressure and may speed things up a bit.
See comments and all, but this code runs like hell - with both List.* and some other smaller optimisations:
let GetNeighbours p w h =
let (f1, f2, f3, f4) = p > w, p % w <> 1, p % w <> 0, p < w * (h - 1)
[
p - w - 1, f1 && f2
p - w, f1
p - w + 1, f1 && f3
p - 1, f2
p + 1, f3
p + w - 1, f4 && f2
p + w, f4
p + w + 1, f4 && f3
]
|> List.choose (fun (s, t) -> if t then Some s else None)
let rec Evolve B S CC g =
let w = 10
let h = 10
let OutputStr = sprintf "Generation %d: %A" g CC // LINE_MARKER_1
printfn "%s" OutputStr
let CCN = CC |> List.map (fun s -> s, GetNeighbours s w h)
let Survivors =
CCN
|> List.choose (fun (s, t) ->
let t =
t
|> List.filter (fun u -> CC |> List.exists ((=) u))
|> List.length
if S |> List.exists ((=) t) then
Some s
else None)
let NewBorns =
CCN
|> List.collect snd
|> List.filter (not << fun s -> CC |> List.exists ((=) s))
|> Seq.countBy id
|> List.ofSeq
|> List.choose (fun (s, t) ->
if B |> List.exists ((=) t) then
Some s
else None)
let NC = List.append Survivors NewBorns
let SWt = new System.Threading.SpinWait()
SWt.SpinOnce()
if System.Console.KeyAvailable then
match (System.Console.ReadKey()).Key with
| System.ConsoleKey.Q -> ()
| _ -> Evolve B S NC (g + 1)
else
Evolve B S NC (g + 1)
let B = [3]
let S = [2; 3]
let IC = [4; 13; 14]
let g = 0
Evolve B S IC g
Just thought I would add a simple answer, in case other beginners like me run into the same problem.
As advised by Ramon Snir, ildjarn and pad above, I changed the Seq.X calls to List.X. I had to add a simple extra casting step to account for the fact that List does not have groupBy, but having done that, the code now runs like a charm!
Thanks a lot.
One of the most amazing characteristics of the ML family of languages is that short code is often fast code and this applies to F# too.
Compare your implementation with the much faster one I blogged here:
let count (a: _ [,]) x y =
let m, n = a.GetLength 0, a.GetLength 1
let mutable c = 0
for x=x-1 to x+1 do
for y=y-1 to y+1 do
if x>=0 && x<m && y>=0 && y<n && a.[x, y] then
c <- c + 1
if a.[x, y] then c-1 else c
let rule (a: _ [,]) x y =
match a.[x, y], count a x y with
| true, (2 | 3) | false, 3 -> true
| _ -> false