Skip to content

Navigation Menu

Sign in
Appearance settings

Search code, repositories, users, issues, pull requests...

Provide feedback

We read every piece of feedback, and take your input very seriously.

Saved searches

Use saved searches to filter your results more quickly
Sign up
Appearance settings

Commit b134e1b

Browse files
committed
refactoring day 18
1 parent 8b14362 commit b134e1b

File tree

2 files changed

+40
-31
lines changed

2 files changed

+40
-31
lines changed

‎src/AOC2017/Day18.hs

Lines changed: 32 additions & 30 deletions
Original file line numberDiff line numberDiff line change
@@ -9,19 +9,19 @@ module AOC2017.Day18 (day18a, day18b) where
99

1010
import AOC2017.Types (Challenge)
1111
import AOC2017.Util.Accum (AccumT(..), execAccumT, look, add)
12-
import AOC2017.Util.Prompt ()
1312
import AOC2017.Util.Tape (Tape(..), HasTape(..), move, unsafeTape)
1413
import Control.Applicative (many, empty)
1514
import Control.Lens (makeClassy, use, at, non, (%=), use, (.=), (<>=), zoom)
1615
import Control.Monad (guard, when)
17-
import Control.Monad.Prompt (MonadPrompt(..), runPromptM)
18-
import Control.Monad.State (MonadState(..), execStateT, State, evalState)
16+
import Control.Monad.Prompt (Prompt, prompt, runPromptM)
17+
import Control.Monad.State (MonadState(get,put), StateT(..), State, execStateT, evalState)
18+
import Control.Monad.Trans.Class (MonadTrans(lift))
1919
import Control.Monad.Trans.Maybe (MaybeT(..))
20-
import Control.Monad.Writer (First(..), Last(..), MonadWriter(..), WriterT(..), Writer, execWriter)
20+
import Control.Monad.Writer (MonadWriter(..), WriterT(..), Writer, execWriter)
2121
import Data.Char (isAlpha)
22-
import Data.Coerce (coerce)
2322
import Data.Kind (Type)
2423
import Data.Maybe (fromJust)
24+
import Data.Monoid (First(..), Last(..))
2525
import qualified Data.Map as M
2626
import qualified Data.Vector.Sized as V
2727

@@ -67,29 +67,36 @@ data Command :: Type -> Type where
6767
CRcv :: Int -> Command Int -- ^ input is current value of buffer
6868
CSnd :: Int -> Command () -- ^ input is thing being sent
6969

70-
rcvMachine :: MonadPrompt Command m => Int -> m Int
70+
type Machine = Prompt Command
71+
72+
rcvMachine :: Int -> Machine Int
7173
rcvMachine = prompt . CRcv
7274

73-
sndMachine :: MonadPromptCommandm=>Int -> m ()
75+
sndMachine :: Int -> Machine ()
7476
sndMachine = prompt . CSnd
7577

7678
data ProgState = PS { _psTape :: Tape Op
7779
, _psRegs :: M.Map Char Int
7880
}
7981
makeClassy ''ProgState
8082

83+
-- | Context in which a 'Duet' program runs
84+
type Duet = MaybeT (StateT ProgState Machine)
85+
execDuet :: Duet a -> ProgState -> Machine ProgState
86+
execDuet = execStateT . runMaybeT
87+
8188
-- | Single step through program tape.
82-
stepTape :: (MonadStateProgStatem, MonadPromptCommandm) =>m ()
89+
stepTape :: Duet ()
8390
stepTape = use (psTape . tFocus) >>= \case
8491
OSnd x -> do
85-
sndMachine =<< addrVal x
92+
lift . lift .sndMachine =<< addrVal x
8693
advance 1
8794
OBin f x y -> do
8895
yVal <- addrVal y
8996
psRegs . at x . non 0 %= (`f` yVal)
9097
advance 1
9198
ORcv x -> do
92-
y <- rcvMachine =<< use (psRegs . at x . non 0)
99+
y <- lift . lift .rcvMachine =<< use (psRegs . at x . non 0)
93100
psRegs . at x . non 0 .= y
94101
advance 1
95102
OJgz x y -> do
@@ -124,14 +131,14 @@ interpretA :: Command a -> PartA a
124131
interpretA = \case
125132
CRcv x -> do
126133
when (x /= 0) $
127-
tell . coerce =<< look
134+
tell . First. getLast =<< look
128135
return x
129136
CSnd x -> add (pure x)
130137

131138
day18a :: Challenge
132-
day18a = show
133-
. execPartA .runPromptM interpretA
134-
. execStateT (runMaybeT (many stepTape)) -- stepTape until program terminates
139+
day18a = show. execPartA
140+
. runPromptM interpretA
141+
. execDuet (many stepTape) -- stepTape until program terminates
135142
. (`PS` M.empty) . parse
136143

137144
{-
@@ -140,11 +147,6 @@ day18a = show
140147
************************
141148
-}
142149

143-
data Thread = T { _tState :: ProgState
144-
, _tBuffer :: [Int]
145-
}
146-
makeClassy ''Thread
147-
148150
-- | Context in which to interpret Command for Part B
149151
type PartB s = MaybeT (State s)
150152

@@ -158,35 +160,35 @@ interpretB = \case
158160
[] -> empty
159161
x:xs -> put xs >> return x
160162

161-
-- runTapeB :: ProgState -> PartB Thread (ProgState, [Int])
162-
-- runTapeB = zoom tBuffer . runWriterT . runPromptM interpretB . execStateT stepTape
163+
data Thread = T { _tState :: ProgState
164+
, _tBuffer :: [Int]
165+
}
166+
makeClassy ''Thread
163167

164168
-- | Single step through a thread. Nothing = either the thread terminates,
165169
-- or requires extra input.
166170
stepThread :: PartB Thread [Int]
167171
stepThread = do
168-
ps0 <- use tState
169-
(ps1, out) <- zoom tBuffer $ runWriterT
170-
. runPromptM interpretB
171-
$ execStateT stepTape ps0
172-
tState .= ps1
172+
machine <- execDuet stepTape <$> use tState
173+
(ps, out) <- runWriterT . zoom tBuffer
174+
$ runPromptM interpretB machine
175+
tState .= ps
173176
return out
174177

175178
type MultiState = V.Vector 2 Thread
176179

177180
-- | Single step through both threads. Nothing = both threads terminate
178-
stepThreads :: PartB MultiState [Int]
181+
stepThreads :: PartB MultiState Int
179182
stepThreads = do
180183
outA <- zoom (V.ix 0) $ concat <$> many stepThread
181184
outB <- zoom (V.ix 1) $ concat <$> many stepThread
182185
V.ix 0 . tBuffer <>= outB
183186
V.ix 1 . tBuffer <>= outA
184187
guard . not $ null outA && null outB
185-
return outB
188+
return $lengthoutB
186189

187190
day18b :: Challenge
188-
day18b (parse->t) = show . length . concat
189-
. fromJust
191+
day18b (parse->t) = show . sum . concat
190192
. evalState (runMaybeT (many stepThreads))
191193
$ ms
192194
where

‎src/AOC2017/Util/Prompt.hs

Lines changed: 8 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -6,13 +6,20 @@ module AOC2017.Util.Prompt (
66
) where
77

88
import Control.Monad.Prompt
9+
import Control.Monad.State
910
import Control.Monad.Trans.Class
11+
import Control.Lens
1012
import Control.Monad.Trans.Maybe
11-
import Control.Monad.Trans.State
1213

1314
instance MonadPrompt p m => MonadPrompt p (StateT s m) where
1415
prompt = lift . prompt
1516

1617
instance MonadPrompt p m => MonadPrompt p (MaybeT m) where
1718
prompt = lift . prompt
1819

20+
instance MonadState s m => MonadState s (PromptT p m) where
21+
get = lift get
22+
put = lift . put
23+
state = lift . state
24+
25+
-- instance Zoom m n s t => Zoom (PromptT p m) (PromptT p n) s t where

0 commit comments

Comments
(0)

AltStyle によって変換されたページ (->オリジナル) /