Merge remote-tracking branch 'origin/master'

Author: Akon32

package.yaml

@@ -47,7 +47,7 @@ executables:
 
 tests:
   icfpc2018-test:
-    main:                Spec.hs
+    main:                Test.hs
     source-dirs:         test
     ghc-options:
     - -threaded

src/Algorithms.hs

@@ -6,6 +6,8 @@ import Control.Monad.State
 import Data.Word
 import Data.Binary (decodeFile)
 import Text.Printf
+import qualified Data.Array.BitArray as BA
+import qualified Data.Set as S
 
 import Trace
 import Sim
@@ -44,9 +46,30 @@ fill bid dir p@(x,y,z) = do
     (neighbour, diff) <- findFreeNeighbour p
     let diff' = negateNear diff
     move bid neighbour
+    grounded <- willBeGrounded p
+    unless grounded $
+      setHarmonics bid High
     issueFill bid diff'
+    setHarmonics bid Low
     step
 
+-- This would be too slow
+-- isGrounded :: P3 -> Generator Bool
+-- isGrounded p = do
+--     matrix <- gets gsFilled
+--     return $ go matrix S.empty p
+--   where
+--     go _ _ (_,0,_) = True
+--     go m visited p@(x,y,z) =
+--       case m BA.!? p of
+--         Nothing -> return False
+--         Just False -> return False
+--         Just True ->
+--           let neighbours = [(x+1, y, z), (x, y+1, z), (x, y, z+1),
+--                             (x-1, y, z), (x, y-1, z), (x, y, z-1)]
+--               nonVisited = [neighbour | neighbour `S.notMember` visited]
+--           in  or [go m (S.insert neighbour visited) neighbour | neighbour <- nonVisited]
+
 makeLine :: Direction -> Resolution -> Word8 -> Word8 -> [P3]
 makeLine dir r y z = 
   case dir of
@@ -98,10 +121,11 @@ dumbHighSolver modelPath tracePath = do
   model <- decodeFile modelPath
   let trace = makeTrace model $ do
                 let bid = 0
-                issue bid Flip
+                -- issueFlip bid
                 dumbFill bid
                 move bid (0,0,0)
-                issue bid Flip
+                -- issueFlip bid
                 issue bid Halt
+  print trace
   writeTrace tracePath trace
 

src/Generator.hs

@@ -39,7 +39,9 @@ type P3d = (Int16, Int16, Int16)
 
 data GeneratorState = GS {
     gsModel :: ModelFile,
-    gsFilled :: BA.BitArray P3,
+    gsHarmonics :: Harmonics,
+    gsFilled :: BA.BitArray P3, -- voxels that are already filled by generator
+    gsGrounded :: BA.BitArray P3, -- grounded voxels
     gsStepNumber :: Step,
     gsAliveBots :: [(Step, [AliveBot])], -- which bots are alive. Record is to be added when set of bots is changed.
     gsBots :: Array BID BotState,
@@ -50,13 +52,14 @@ maxBID :: BID
 maxBID = 20
 
 initState :: ModelFile -> GeneratorState
-initState model = GS model filled 0 [(0,[bid])] bots traces
+initState model = GS model Low filled grounded 0 [(0,[bid])] bots traces
   where
     bid = 0
     bots   = array (0, maxBID) [(bid, Bot bid (0,0,0) []) | bid <- [0 .. maxBID]]
     traces = array (0, maxBID) [(bid, Seq.empty) | bid <- [0 .. maxBID]]
     r = mfResolution model
     filled = BA.array ((0,0,0), (r-1,r-1,r-1)) [((x,y,z), False) | x <- [0..r-1], y <- [0..r-1], z <- [0..r-1]]
+    grounded = BA.array ((0,0,0), (r-1,r-1,r-1)) [((x,y,z), False) | x <- [0..r-1], y <- [0..r-1], z <- [0..r-1]]
 
 type Generator a = State GeneratorState a
 
@@ -89,6 +92,23 @@ issue bid cmd = do
   let trace' = trace |> cmd
   modify $ \st -> st {gsTraces = gsTraces st // [(bid, trace')]}
 
+flipH :: Harmonics -> Harmonics
+flipH Low = High
+flipH High = Low
+
+-- | Issue Flip command and remember resulting harmonics.
+issueFlip :: BID -> Generator ()
+issueFlip bid = do
+  modify $ \st -> st {gsHarmonics = flipH (gsHarmonics st)}
+  issue bid Flip
+
+-- | Set harmonics to target value
+setHarmonics :: BID -> Harmonics -> Generator ()
+setHarmonics bid target = do
+  current <- gets gsHarmonics
+  when (current /= target) $
+      issueFlip bid
+
 nearPlus :: P3 -> NearDiff -> P3
 nearPlus (x,y,z) (NearDiff dx dy dz) = (x+fromIntegral dx, y+fromIntegral dy, z+fromIntegral dz)
 
@@ -99,12 +119,47 @@ negateNear (NearDiff dx dy dz) = NearDiff (-dx) (-dy) (-dz)
 -- This will mark the voxel as filled in generator's state
 issueFill :: BID -> NearDiff -> Generator ()
 issueFill bid nd = do
-  bot <- getBot bid
-  let c' = nearPlus (_pos bot) nd
-  filled <- isFilled c'
-  if filled
-    then fail $ "Voxel is already filled: " ++ show c'
-    else issue bid $ Fill nd
+    bot <- getBot bid
+    let c' = nearPlus (_pos bot) nd
+    filled <- isFilled c'
+    if filled
+      then fail $ "Voxel is already filled: " ++ show c'
+      else do
+           issue bid $ Fill nd
+           modify $ \st -> st {gsFilled = gsFilled st BA.// [(c', True)]}
+           updateGrounded c'
+  where
+    updateGrounded :: P3 -> Generator ()
+    updateGrounded p@(x,y,z) = do
+        filled <- gets gsFilled
+        grounded <- gets gsGrounded
+        let result = check filled grounded p
+        modify $ \st -> st {gsGrounded = gsGrounded st BA.// [(p, result)]}
+      where
+        check _ _ (_,0,_) = True
+        check filled grounded p@(x,y,z) =
+          if filled BA.! p
+            then
+              let neighbours = [(x+1, y, z), (x, y+1, z), (x, y, z+1),
+                                (x-1, y, z), (x, y-1, z), (x, y, z-1)]
+              in  or [grounded BA.! neighbour | neighbour <- neighbours]
+            else False
+
+-- | Is voxel grounded?
+-- This works by definition, i.e. always returns False for non-filled voxels.
+isGrounded :: P3 -> Generator Bool
+isGrounded p = do
+  grounded <- gets gsGrounded
+  return $ grounded BA.! p
+
+-- | Will voxel become grounded if we fill it?
+-- This checks if any neighbour voxel is grounded.
+willBeGrounded :: P3 -> Generator Bool
+willBeGrounded (x,y,z) = do
+  grounded <- gets gsGrounded
+  let neighbours = [(x+1, y, z), (x, y+1, z), (x, y, z+1),
+                    (x-1, y, z), (x, y-1, z), (x, y, z-1)]
+  return $ or [fromMaybe False (grounded BA.!? neighbour) | neighbour <- neighbours]
 
 -- | Switch to the next step.
 -- If we did not issue commands for some bots on current steps,

src/Optimizations.hs

@@ -0,0 +1,58 @@
+-- | Optimizations for sequences of commands.
+--
+-- Each optimizations replaces first occurrence of a pattern with an optimized
+-- version.  It's up to you to figure out if the result is better than the
+-- input, and if you should re-run optimizations to find new occurrences of
+-- patterns.
+--
+-- WARNING: For now, these functions assume that there is only one nanobot!
+module Optimizations where
+
+import Control.Monad (forM)
+
+import Trace
+
+import Debug.Trace
+
+-- | Returns all possible optimizations of a given command sequence.
+optimize :: [Command] -> [[Command]]
+optimize [] = []
+optimize cmds = go [cmds] [cmds]
+  where
+  go :: [[Command]] -> [[Command]] -> [[Command]]
+  go [] optimized = optimized
+  go (t:stack) optimized =
+    let
+      new = map (\f -> f t) optimizers
+      new' = filter (/= t) new
+    in go (new' ++ stack) (new' ++ optimized)
+
+  optimizers :: [[Command] -> [Command]]
+  optimizers = [splitLMove, mergeSMoves]
+
+-- | Turns [LMove a b, Wait] into [SMove a, SMove b]
+--
+-- The latter consumes 4 less energy points than the former.
+--
+-- Note: it doesn't make sense to split [LMove a b] into two SMoves because the
+-- extra step will consume 3 R³ energy points, which is detrimental for any
+-- R greater than one.
+splitLMove :: [Command] -> [Command]
+splitLMove [] = []
+splitLMove ((LMove a b):Wait:cmds) =
+  (SMove (fromShortLinDiff a)) : (SMove (fromShortLinDiff b)) : cmds
+splitLMove (cmd:cmds) = cmd : (splitLMove cmds)
+
+-- | Turns [SMove a, SMove b] into [SMove x] if a and b are on the same axis
+-- and can be combined.
+mergeSMoves :: [Command] -> [Command]
+mergeSMoves [] = []
+mergeSMoves (m1@(SMove (LongLinDiff a1 d1)):m2@(SMove (LongLinDiff a2 d2)):cmds)
+  | (a1 /= a2) || (d1 + d2 < -15) || (d1 + d2 > 15)
+      = m1 : (mergeSMoves (m2:cmds))
+  | otherwise =
+      let d = d1 + d2
+      in if d == 0
+        then cmds
+        else (SMove (LongLinDiff a1 d)) : cmds
+mergeSMoves (cmd:cmds) = cmd : (mergeSMoves cmds)

src/Trace.hs

@@ -167,6 +167,12 @@ instance Coded Command where
 
         | otherwise = error "Command.decode: invalid input"
 
+-- | Converts short linear difference into a long linear difference.
+--
+-- This conversion is valid since any short linear difference satisfies
+-- mlen(ld) ≤ 5, which also satisfies LongLinDiff's predicate of mlen(ld) ≤ 15.
+fromShortLinDiff :: ShortLinDiff -> LongLinDiff
+fromShortLinDiff (ShortLinDiff axis diff) = LongLinDiff axis diff
 
 encodeL :: Coded a => a -> L.ByteString
 encodeL x = runPutL . runEncode $ encode x >> flush

test/Test.hs

@@ -0,0 +1,10 @@
+import Test.Tasty
+
+import TestSpec
+import TestOptimizations
+
+main :: IO ()
+main = defaultMain tests
+
+tests :: TestTree
+tests = testGroup "Tests" [specExamples, codec, optimizations]

test/TestOptimizations.hs

@@ -0,0 +1,79 @@
+module TestOptimizations where
+
+import Test.Tasty
+import Test.Tasty.HUnit
+
+import Optimizations
+import Trace
+
+optimizations :: TestTree
+optimizations = testGroup "Optimizations"
+  [ testSplitLMove
+  , testMergeSMoves
+  ]
+
+testSplitLMove :: TestTree
+testSplitLMove = testGroup "splitLMove"
+  [
+    testCase "Empty input" $ splitLMove [] @?= []
+
+  , testCase "Unoptimal input" $
+      let
+        a = ShortLinDiff X 3
+        a' = fromShortLinDiff a
+        b = ShortLinDiff Z (-1)
+        b' = fromShortLinDiff b
+      in splitLMove [LMove a b, Wait] @?= [SMove a', SMove b']
+
+  , testCase "Only first occurrence is optimized" $
+      let
+        a = ShortLinDiff X 3
+        a' = fromShortLinDiff a
+        b = ShortLinDiff Z (-1)
+        b' = fromShortLinDiff b
+      in
+        splitLMove [LMove a b, Wait, LMove a b, Wait]
+        @?= [SMove a', SMove b', LMove a b, Wait]
+  ]
+
+testMergeSMoves :: TestTree
+testMergeSMoves = testGroup "mergeSMoves"
+  [ testCase "Empty input" $ mergeSMoves [] @?= []
+
+  , testCase "SMoves on different axis" $
+      let
+        m1 = SMove (LongLinDiff X 13)
+        m2 = SMove (LongLinDiff Y (-11))
+      in mergeSMoves [m1, m2] @?= [m1, m2]
+
+  , testCase "Long SMoves can't be combined" $
+      let
+        m1 = SMove (LongLinDiff X 13)
+        m2 = SMove (LongLinDiff X 11)
+      in mergeSMoves [m1, m2] @?= [m1, m2]
+
+  , testCase "Unoptimal input.1" $
+      let
+        m1 = SMove (LongLinDiff X 4)
+        m2 = SMove (LongLinDiff X 3)
+        result = SMove (LongLinDiff X 7)
+      in mergeSMoves [m1, m2] @?= [result]
+  , testCase "Unoptimal input.2" $
+      let
+        m1 = SMove (LongLinDiff Z (-11))
+        m2 = SMove (LongLinDiff Z (-4))
+        result = SMove (LongLinDiff Z (-15))
+      in mergeSMoves [m1, m2] @?= [result]
+  , testCase "Unoptimal input.3" $
+      let
+        m1 = SMove (LongLinDiff Y (-3))
+        m2 = SMove (LongLinDiff Y 3)
+      in mergeSMoves [m1, m2] @?= []
+
+  , testCase "Only first occurrence is optimized" $
+      let
+        m1 = SMove (LongLinDiff X 4)
+        m2 = SMove (LongLinDiff X 3)
+        combined = SMove (LongLinDiff X 7)
+      in mergeSMoves [m1, m2, m1, m2] @?= [combined, m1, m2]
+  ]

test/Spec.hs test/TestSpec.hstest/Spec.hs renamed to test/TestSpec.hs

@@ -1,5 +1,10 @@
 {-# LANGUAGE BinaryLiterals #-}
 
+module TestSpec (
+  specExamples,
+  codec
+) where
+
 import Test.Tasty
 import Test.Tasty.HUnit
 
@@ -15,12 +20,6 @@ assert :: String -> Bool -> IO ()
 assert _ True = return ()
 assert message False = fail message
 
-main :: IO ()
-main = defaultMain tests
-
-tests :: TestTree
-tests = testGroup "Tests" [specExamples, codec]
-
 specExamples :: TestTree
 specExamples = testGroup "Specification examples"
   [