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 81b840d

Browse files
committed
day 18 refactor using :|:
1 parent 9f4240a commit 81b840d

File tree

4 files changed

+99
-79
lines changed

4 files changed

+99
-79
lines changed

‎aoc2017.cabal

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -53,6 +53,7 @@ library
5353
AOC2017.Day25
5454
build-depends: base >= 4.7 && < 5
5555
, MonadPrompt
56+
, pointedlist
5657
, aeson
5758
, arithmoi
5859
, bytestring
@@ -70,9 +71,11 @@ library
7071
, monad-control
7172
, monad-loops
7273
, mtl
74+
, reflection
7375
, split
7476
, text
7577
, transformers
78+
, type-combinators
7679
, vector
7780
, vector-sized
7881
, yaml

‎reflections.md

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -2218,3 +2218,4 @@ mean 2.643 s (2.607 s .. 2.668 s)
22182218
std dev 38.04 ms (0.0 s .. 43.77 ms)
22192219
variance introduced by outliers: 19% (moderately inflated)
22202220
```
2221+

‎src/AOC2017/Day18.hs

Lines changed: 94 additions & 78 deletions
Original file line numberDiff line numberDiff line change
@@ -4,24 +4,27 @@
44
{-# LANGUAGE KindSignatures #-}
55
{-# LANGUAGE MultiParamTypeClasses #-}
66
{-# LANGUAGE TemplateHaskell #-}
7+
{-# LANGUAGE TypeOperators #-}
78

89
module AOC2017.Day18 (day18a, day18b) where
910

1011
import AOC2017.Types (Challenge)
1112
import AOC2017.Util.Accum (AccumT(..), execAccumT, look, add)
12-
import AOC2017.Util.Tape (Tape(..), HasTape(..), move, unsafeTape)
13-
import Control.Applicative (many, empty)
14-
import Control.Lens (makeClassy, use, at, non, (%=), use, (.=), (<>=), zoom)
15-
import Control.Monad (guard, when)
13+
import Control.Applicative
14+
import Control.Lens
15+
import Control.Monad
16+
import Control.Monad.Fail
1617
import Control.Monad.Prompt (Prompt, prompt, runPromptM)
17-
import Control.Monad.State (MonadState(get,put), StateT(..), State, execStateT, evalState)
18+
import Control.Monad.State (MonadState, StateT(..), State, execStateT, evalState)
1819
import Control.Monad.Trans.Class (MonadTrans(lift))
1920
import Control.Monad.Trans.Maybe (MaybeT(..))
20-
import Control.Monad.Writer (MonadWriter(..), WriterT(..), Writer, execWriter)
21+
import Control.Monad.Writer
2122
import Data.Char (isAlpha)
2223
import Data.Kind (Type)
2324
import Data.Maybe (fromJust)
2425
import Data.Monoid (First(..), Last(..))
26+
import Data.Type.Disjunction
27+
import qualified Data.List.PointedList as P
2528
import qualified Data.Map as M
2629
import qualified Data.Vector.Sized as V
2730

@@ -53,135 +56,148 @@ parseOp inp = case words inp of
5356
"jgz":(addr->x):(addr->y):_ -> OJgz x y
5457
_ -> error "Bad parse"
5558

56-
parse :: String -> Tape Op
57-
parse = unsafeTape . map parseOp . lines
59+
parse :: String -> P.PointedList Op
60+
parse = fromJust .P.fromList . map parseOp . lines
5861

5962
{-
6063
**************************
6164
* The Abstract Machine *
6265
**************************
6366
-}
6467

68+
data Memory :: Type -> Type where
69+
MGet :: Char -> Memory Int
70+
MSet :: Char -> Int -> Memory ()
71+
MMov :: Int -> Memory ()
72+
MPk :: Memory Op
73+
6574
-- | Abstract data type describing "IO" available to the abstract machine
6675
data Command :: Type -> Type where
6776
CRcv :: Int -> Command Int -- ^ input is current value of buffer
6877
CSnd :: Int -> Command () -- ^ input is thing being sent
6978

70-
type Machine = Prompt Command
71-
72-
rcvMachine :: Int -> Machine Int
73-
rcvMachine = prompt . CRcv
74-
75-
sndMachine :: Int -> Machine ()
76-
sndMachine = prompt . CSnd
77-
78-
data ProgState = PS { _psTape :: Tape Op
79+
type Machine = Prompt (Memory :|: Command)
80+
81+
cRcv :: Int -> Machine Int
82+
cRcv = prompt . R . CRcv
83+
cSnd :: Int -> Machine ()
84+
cSnd = prompt . R . CSnd
85+
cGet :: Char -> Machine Int
86+
cGet = prompt . L . MGet
87+
cSet :: Char -> Int -> Machine ()
88+
cSet r = prompt . L . MSet r
89+
cMov :: Int -> Machine ()
90+
cMov = prompt . L . MMov
91+
cPk :: Machine Op
92+
cPk = prompt $ L MPk
93+
94+
data ProgState = PS { _psTape :: P.PointedList Op
7995
, _psRegs :: M.Map Char Int
8096
}
8197
makeClassy ''ProgState
8298

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-
8899
-- | Single step through program tape.
89-
stepTape :: Duet ()
90-
stepTape = use (psTape . tFocus) >>= \case
100+
stepTape :: Machine ()
101+
stepTape = cPk >>= \case
91102
OSnd x -> do
92-
lift . lift . sndMachine =<< addrVal x
93-
advance 1
103+
cSnd =<< addrVal x
104+
cMov 1
94105
OBin f x y -> do
95106
yVal <- addrVal y
96-
psRegs . at x . non 0%=(`f` yVal)
97-
advance 1
107+
cSet x . (`f` yVal)=<< cGet x
108+
cMov 1
98109
ORcv x -> do
99-
y <- lift . lift . rcvMachine =<< use (psRegs . at x . non 0)
100-
psRegs . at x . non 0.= y
101-
advance 1
110+
y <- cRcv =<< cGet x
111+
cSet x y
112+
cMov 1
102113
OJgz x y -> do
103114
xVal <- addrVal x
104-
moveAmt <- if xVal > 0
105-
then addrVal y
106-
else return 1
107-
advance moveAmt
115+
cMov =<< if xVal > 0
116+
then addrVal y
117+
else return 1
108118
where
109-
addrVal (Left r) = use (psRegs . at r . non 0)
119+
addrVal (Left r ) = cGet r
110120
addrVal (Right x) = return x
111-
advance n = do
112-
Just t' <- move n <$> use psTape
121+
122+
interpMem
123+
:: (MonadState s m, MonadPlus m, HasProgState s)
124+
=> Memory a
125+
-> m a
126+
interpMem = \case
127+
MGet c -> use (psRegs . at c . non 0)
128+
MSet c x -> psRegs . at c . non 0 .= x
129+
MMov n -> do
130+
Just t' <- P.moveN n <$> use psTape
113131
psTape .= t'
132+
MPk -> use (psTape . P.focus)
114133

115134
{-
116135
************************
117136
* Context for Part A *
118137
************************
119138
-}
120139

121-
-- | Context in which to interpret Command for Part A
122-
--
123-
-- Accum parameter is the most recent sent item. Writer parameter is the
124-
-- first Rcv'd item.
125-
type PartA = AccumT (Last Int) (Writer (First Int))
126-
execPartA :: PartA a -> Int
127-
execPartA = fromJust . getFirst . execWriter . flip execAccumT mempty
140+
type PartA = MaybeT (StateT ProgState (AccumT (Last Int) (Writer (First Int))))
141+
142+
execPartA :: PartA a -> ProgState -> Int
143+
execPartA p s = fromJust . getFirst . execWriter
144+
. flip execAccumT mempty
145+
. flip execStateT s
146+
. runMaybeT
147+
$ p
128148

129149
-- | Interpet Command for Part A
130-
interpretA :: Command a -> PartA a
131-
interpretA = \case
132-
CRcv x -> do
150+
interpA :: Command a -> PartA a
151+
interpA = \case
152+
CRcv x -> lift . lift $do
133153
when (x /= 0) $
134154
tell . First . getLast =<< look
135155
return x
136-
CSnd x -> add (pure x)
156+
CSnd x -> lift . lift $
157+
add (Last (Just x))
137158

138159
day18a :: Challenge
139-
day18a = show. execPartA
140-
. runPromptM interpretA
141-
. execDuet (many stepTape) -- stepTape until program terminates
142-
. (`PS` M.empty) .parse
160+
day18a = show
161+
. execPartA (many .runPromptM (interpMem >|< interpA) $ stepTape)
162+
. (`PS` M.empty)
163+
. parse
143164

144165
{-
145166
************************
146167
* Context for Part B *
147168
************************
148169
-}
149170

150-
-- | Context in which to interpret Command for Part B
151-
type PartB s = MaybeT (State s)
152-
153-
-- | Interpet Command for Part B, with an [Int] writer side-channel
154-
interpretB
155-
:: Command a
156-
-> WriterT [Int] (PartB [Int]) a
157-
interpretB = \case
158-
CSnd x -> tell [x]
159-
CRcv _ -> get >>= \case
160-
[] -> empty
161-
x:xs -> put xs >> return x
162-
163171
data Thread = T { _tState :: ProgState
164172
, _tBuffer :: [Int]
165173
}
166174
makeClassy ''Thread
167175

168-
-- | Single step through a thread. Nothing = either the thread terminates,
169-
-- or requires extra input.
170-
stepThread :: PartB Thread [Int]
171-
stepThread = do
172-
machine <- execDuet stepTape <$> use tState
173-
(ps, out) <- runWriterT . zoom tBuffer
174-
$ runPromptM interpretB machine
175-
tState .= ps
176-
return out
176+
instance HasProgState Thread where
177+
progState = tState
178+
179+
-- | Interpet Command for Part B, with an [Int] writer side-channel
180+
interpB
181+
:: (MonadFail m, MonadState s m, HasThread s)
182+
=> Command a
183+
-> WriterT [Int] m a
184+
interpB = \case
185+
CSnd x -> tell [x]
186+
CRcv _ -> do
187+
x:xs <- use tBuffer
188+
tBuffer .= xs
189+
return x
177190

178191
type MultiState = V.Vector 2 Thread
179192

180193
-- | Single step through both threads. Nothing = both threads terminate
181-
stepThreads :: PartB MultiState Int
194+
stepThreads
195+
:: MaybeT (State MultiState) Int
182196
stepThreads = do
183-
outA <- zoom (V.ix 0) $ concat <$> many stepThread
184-
outB <- zoom (V.ix 1) $ concat <$> many stepThread
197+
outA <- execWriterT $
198+
zoom (V.ix 0) . many $ runPromptM (interpMem >|< interpB) stepTape
199+
outB <- execWriterT $
200+
zoom (V.ix 1) . many $ runPromptM (interpMem >|< interpB) stepTape
185201
V.ix 0 . tBuffer <>= outB
186202
V.ix 1 . tBuffer <>= outA
187203
guard . not $ null outA && null outB

‎stack.yaml

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -15,7 +15,7 @@
1515
# resolver:
1616
# name: custom-snapshot
1717
# location: "./custom-snapshot.yaml"
18-
resolver: lts-10.0
18+
resolver: lts-10.3
1919

2020
# User packages to be built.
2121
# Various formats can be used as shown in the example below.

0 commit comments

Comments
(0)

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