{-# Language BangPatterns, LambdaCase, OverloadedStrings #-}
{-|
Module      : Main
Description : Day 23 solution
Copyright   : (c) Eric Mertens, 2021
License     : ISC
Maintainer  : emertens@gmail.com

<https://adventofcode.com/2015/day/23>

We're given a program that computes Collatz conjecture in a
purpose-built assembly language.

-}
module Main (main) where

import Advent (getInputLines, arrIx)
import Advent.ReadS
import Control.Applicative (empty, optional)
import Data.Array (Array, listArray)

-- | >>> :main
-- 255
-- 334
main :: IO ()
IO ()
main =
  do Array Int Instr
pgm <- [Instr] -> Array Int Instr
forall a. [a] -> Array Int a
toArray ([Instr] -> Array Int Instr)
-> ([String] -> [Instr]) -> [String] -> Array Int Instr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Instr) -> [String] -> [Instr]
forall a b. (a -> b) -> [a] -> [b]
map (P Instr -> String -> Instr
forall a. P a -> String -> a
runP P Instr
pInstr) ([String] -> Array Int Instr)
-> IO [String] -> IO (Array Int Instr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Int -> IO [String]
getInputLines Int
2015 Int
23
     Int -> IO ()
forall a. Show a => a -> IO ()
print (Array Int Instr -> Int -> Int -> Int
program Array Int Instr
pgm Int
0 Int
0)
     Int -> IO ()
forall a. Show a => a -> IO ()
print (Array Int Instr -> Int -> Int -> Int
program Array Int Instr
pgm Int
1 Int
0)

-- | Turn a list into a zero-indexed array
toArray :: [a] -> Array Int a
toArray :: forall a. [a] -> Array Int a
toArray [a]
xs = (Int, Int) -> [a] -> Array Int a
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0,[a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [a]
xs

-- | Run a program to completion starting from the first instruction.
program ::
  Array Int Instr {- ^ program -} ->
  Int {- ^ initial a register -} ->
  Int {- ^ initial b register -} ->
  Int {- ^ final b register -}
program :: Array Int Instr -> Int -> Int -> Int
program Array Int Instr
pgm = Int -> Int -> Int -> Int
forall {a} {a}. (Integral a, Integral a) => Int -> a -> a -> a
loop Int
0
  where
    loop :: Int -> a -> a -> a
loop !Int
i !a
a !a
b =
      case Array Int Instr -> Int -> Maybe Instr
forall (a :: * -> * -> *) e i (f :: * -> *).
(IArray a e, Ix i, Alternative f) =>
a i e -> i -> f e
arrIx Array Int Instr
pgm Int
i of
        Maybe Instr
Nothing -> a
b
        Just Instr
instr ->
          case Instr
instr of
            Hlf Register
A   -> Int -> a -> a -> a
loop (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (a
aa -> a -> a
forall a. Integral a => a -> a -> a
`quot`a
2) a
b
            Hlf Register
B   -> Int -> a -> a -> a
loop (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) a
a (a
ba -> a -> a
forall a. Integral a => a -> a -> a
`quot`a
2)
            Tpl Register
A   -> Int -> a -> a -> a
loop (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (a
3a -> a -> a
forall a. Num a => a -> a -> a
*a
a) a
b
            Tpl Register
B   -> Int -> a -> a -> a
loop (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) a
a (a
3a -> a -> a
forall a. Num a => a -> a -> a
*a
b)
            Inc Register
A   -> Int -> a -> a -> a
loop (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (a
aa -> a -> a
forall a. Num a => a -> a -> a
+a
1) a
b
            Inc Register
B   -> Int -> a -> a -> a
loop (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) a
a (a
ba -> a -> a
forall a. Num a => a -> a -> a
+a
1)
            Jmp Int
o   -> Int -> a -> a -> a
loop (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
o) a
a a
b
            Jie Register
A Int
o -> Int -> a -> a -> a
loop (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+if a -> Bool
forall a. Integral a => a -> Bool
even a
a then Int
o else Int
1) a
a a
b
            Jie Register
B Int
o -> Int -> a -> a -> a
loop (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+if a -> Bool
forall a. Integral a => a -> Bool
even a
b then Int
o else Int
1) a
a a
b
            Jio Register
A Int
o -> Int -> a -> a -> a
loop (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+if a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
1 then Int
o else Int
1) a
a a
b
            Jio Register
B Int
o -> Int -> a -> a -> a
loop (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+if a
b a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
1 then Int
o else Int
1) a
a a
b

-- * Program data type

-- | A program instruction
data Instr
  = Hlf Register -- ^ divide the register's contents by 2
  | Tpl Register -- ^ multiply the register's contents by 3
  | Inc Register -- ^ increment the register
  | Jmp Int -- ^ jump to a fixed offset
  | Jie Register Int -- ^ jump to a fixed offset when the register is even
  | Jio Register Int -- ^ jump to a fixed offset when the register is odd
  deriving Int -> Instr -> ShowS
[Instr] -> ShowS
Instr -> String
(Int -> Instr -> ShowS)
-> (Instr -> String) -> ([Instr] -> ShowS) -> Show Instr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Instr -> ShowS
showsPrec :: Int -> Instr -> ShowS
$cshow :: Instr -> String
show :: Instr -> String
$cshowList :: [Instr] -> ShowS
showList :: [Instr] -> ShowS
Show

-- | A program register
data Register = A | B
  deriving Int -> Register -> ShowS
[Register] -> ShowS
Register -> String
(Int -> Register -> ShowS)
-> (Register -> String) -> ([Register] -> ShowS) -> Show Register
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Register -> ShowS
showsPrec :: Int -> Register -> ShowS
$cshow :: Register -> String
show :: Register -> String
$cshowList :: [Register] -> ShowS
showList :: [Register] -> ShowS
Show

-- * Parsing

-- | Parse a single instruction
pInstr :: P Instr
pInstr :: P Instr
pInstr = ReadS String -> P String
forall a. ReadS a -> P a
P ReadS String
lex P String -> (String -> P Instr) -> P Instr
forall a b. P a -> (a -> P b) -> P b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  String
"hlf" -> Register -> Instr
Hlf (Register -> Instr) -> P Register -> P Instr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P Register
pReg
  String
"tpl" -> Register -> Instr
Tpl (Register -> Instr) -> P Register -> P Instr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P Register
pReg
  String
"inc" -> Register -> Instr
Inc (Register -> Instr) -> P Register -> P Instr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P Register
pReg
  String
"jmp" -> Int -> Instr
Jmp (Int -> Instr) -> P Int -> P Instr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P Int
pOffset
  String
"jie" -> Register -> Int -> Instr
Jie (Register -> Int -> Instr) -> P Register -> P (Int -> Instr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P Register
pReg P (Int -> Instr) -> P String -> P (Int -> Instr)
forall a b. P a -> P b -> P a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* P String
"," P (Int -> Instr) -> P Int -> P Instr
forall a b. P (a -> b) -> P a -> P b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> P Int
pOffset
  String
"jio" -> Register -> Int -> Instr
Jio (Register -> Int -> Instr) -> P Register -> P (Int -> Instr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P Register
pReg P (Int -> Instr) -> P String -> P (Int -> Instr)
forall a b. P a -> P b -> P a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* P String
"," P (Int -> Instr) -> P Int -> P Instr
forall a b. P (a -> b) -> P a -> P b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> P Int
pOffset
  String
_     -> P Instr
forall a. P a
forall (f :: * -> *) a. Alternative f => f a
empty

-- | Parse a jump offset
pOffset :: P Int
pOffset :: P Int
pOffset = P String -> P (Maybe String)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional P String
"+" P (Maybe String) -> P Int -> P Int
forall a b. P a -> P b -> P b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ReadS Int -> P Int
forall a. ReadS a -> P a
P ReadS Int
forall a. Read a => ReadS a
reads

-- | Parse a register a or b
pReg :: P Register
pReg :: P Register
pReg = ReadS String -> P String
forall a. ReadS a -> P a
P ReadS String
lex P String -> (String -> P Register) -> P Register
forall a b. P a -> (a -> P b) -> P b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  String
"a" -> Register -> P Register
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Register
A
  String
"b" -> Register -> P Register
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Register
B
  String
_   -> P Register
forall a. P a
forall (f :: * -> *) a. Alternative f => f a
empty