fork(2) download
  1. {-# LANGUAGE BangPatterns #-}
  2. import Control.Monad
  3.  
  4. data Tree a
  5. = Nil
  6. | Branch a (Tree a) (Tree a)
  7. deriving (Show, Eq)
  8.  
  9. notEach :: Tree Bool -> [Tree Bool]
  10. notEach tree = go id tree [] where
  11. go :: (Tree Bool -> Tree Bool) -> Tree Bool -> [Tree Bool] -> [Tree Bool]
  12. go cont Nil rest = rest
  13. go cont (Branch x left right) rest =
  14. -- This made a 0.2s difference because without it, ghc couldn't move the
  15. -- case out of the application to the Branch constructor
  16. -- (because it might not get evaluated depending on what cont does)
  17. -- With the ! it is able to compile it to a direct join point
  18. let !flipped = not x in
  19. cont (Branch flipped left right) :
  20. go (rebuildLeft cont x right) left (go (rebuildRight cont x left) right rest)
  21.  
  22.  
  23. rebuildLeft :: (Tree Bool -> Tree Bool) -> Bool -> Tree Bool -> Tree Bool -> Tree Bool
  24. rebuildLeft cont x right leftFlipped = cont (Branch x leftFlipped right)
  25.  
  26. rebuildRight :: (Tree Bool -> Tree Bool) -> Bool -> Tree Bool -> Tree Bool -> Tree Bool
  27. rebuildRight cont x left rightFlipped = cont (Branch x left rightFlipped)
  28.  
  29. procreateL :: Int -> Tree Bool
  30. procreateL 0 = Nil
  31. procreateL n = Branch (n `rem` 2 == 0) (procreateL (n - 1)) (procreateL (n `div` 2))
  32.  
  33. procreateR :: Int -> Tree Bool
  34. procreateR 0 = Nil
  35. procreateR n = Branch (n `rem` 2 == 0) (procreateR (n `div` 2)) (procreateR (n - 1))
  36.  
  37. test :: IO ()
  38. test = do
  39. guard $ notEach (procreateL 3) == [Branch True (Branch True (Branch False Nil Nil) (Branch False Nil Nil)) (Branch False Nil Nil),Branch False (Branch False (Branch False Nil Nil) (Branch False Nil Nil)) (Branch False Nil Nil),Branch False (Branch True (Branch True Nil Nil) (Branch False Nil Nil)) (Branch False Nil Nil),Branch False (Branch True (Branch False Nil Nil) (Branch True Nil Nil)) (Branch False Nil Nil),Branch False (Branch True (Branch False Nil Nil) (Branch False Nil Nil)) (Branch True Nil Nil)]
  40. guard $ notEach (procreateR 3) == [Branch True (Branch False Nil Nil) (Branch True (Branch False Nil Nil) (Branch False Nil Nil)),Branch False (Branch True Nil Nil) (Branch True (Branch False Nil Nil) (Branch False Nil Nil)),Branch False (Branch False Nil Nil) (Branch False (Branch False Nil Nil) (Branch False Nil Nil)),Branch False (Branch False Nil Nil) (Branch True (Branch True Nil Nil) (Branch False Nil Nil)),Branch False (Branch False Nil Nil) (Branch True (Branch False Nil Nil) (Branch True Nil Nil))]
  41. guard $ length (notEach $ procreateL 150) == 1564307
  42. guard $ length (notEach $ procreateR 150) == 1564307
  43.  
  44. main = test
Success #stdin #stdout 0.45s 95452KB
stdin
Standard input is empty
stdout
Standard output is empty