{-# LANGUAGE RankNTypes #-}

module Nes.APU.BusInterface.Status (write4015, read4015) where

import Control.Lens (Lens')
import Control.Monad
import Data.Bits
import Nes.APU.Monad
import Nes.APU.State
import Nes.APU.State.DMC
import Nes.APU.State.FrameCounter (FrameCounter (frameInterruptFlag))
import Nes.APU.State.LengthCounter
import Nes.APU.Tick (setFrameInterruptFlag)
import Nes.Internal.MonadState
import Nes.Interrupt
import Nes.Memory

{-# INLINE write4015 #-}
write4015 :: Byte -> APU r ()
write4015 :: forall r. Byte -> APU r ()
write4015 Byte
byte = do
    let enablePulse1Lc :: Bool
enablePulse1Lc = Byte
byte Byte -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`testBit` Int
0
        enablePulse2Lc :: Bool
enablePulse2Lc = Byte
byte Byte -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`testBit` Int
1
        enableTriangleLc :: Bool
enableTriangleLc = Byte
byte Byte -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`testBit` Int
2
        enableNoiseLc :: Bool
enableNoiseLc = Byte
byte Byte -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`testBit` Int
3
        enableDmc :: Bool
enableDmc = Byte
byte Byte -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`testBit` Int
4
    Bool -> Lens' APUState Pulse -> APU r ()
forall a r.
HasLengthCounter a =>
Bool -> Lens' APUState a -> APU r ()
toggleLengthCounter Bool
enablePulse1Lc (Pulse -> f Pulse) -> APUState -> f APUState
Lens' APUState Pulse
pulse1
    Bool -> Lens' APUState Pulse -> APU r ()
forall a r.
HasLengthCounter a =>
Bool -> Lens' APUState a -> APU r ()
toggleLengthCounter Bool
enablePulse2Lc (Pulse -> f Pulse) -> APUState -> f APUState
Lens' APUState Pulse
pulse2
    Bool -> Lens' APUState Triangle -> APU r ()
forall a r.
HasLengthCounter a =>
Bool -> Lens' APUState a -> APU r ()
toggleLengthCounter Bool
enableTriangleLc (Triangle -> f Triangle) -> APUState -> f APUState
Lens' APUState Triangle
triangle
    Bool -> Lens' APUState Noise -> APU r ()
forall a r.
HasLengthCounter a =>
Bool -> Lens' APUState a -> APU r ()
toggleLengthCounter Bool
enableNoiseLc (Noise -> f Noise) -> APUState -> f APUState
Lens' APUState Noise
noise
    (DMC -> Identity DMC) -> APUState -> Identity APUState
Lens' APUState DMC
dmc ((DMC -> Identity DMC) -> APUState -> Identity APUState)
-> (DMC -> DMC) -> APU r ()
forall s (m :: * -> *) a.
MonadState s m =>
ASetter' s a -> (a -> a) -> m ()
%= \DMC
t ->
        if Bool
enableDmc
            -- TODO If there are bits remaining in the 1-byte sample buffer, these will finish playing before the next sample is fetched.
            then if DMC -> Int
sampleBytesRemaining DMC
t Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then DMC -> DMC
restartSample DMC
t else DMC
t
            else DMC
t{sampleBytesRemaining = 0}

{-# INLINE toggleLengthCounter #-}
toggleLengthCounter :: (HasLengthCounter a) => Bool -> Lens' APUState a -> APU r ()
toggleLengthCounter :: forall a r.
HasLengthCounter a =>
Bool -> Lens' APUState a -> APU r ()
toggleLengthCounter Bool
enable Lens' APUState a
l =
    (a -> Identity a) -> APUState -> Identity APUState
Lens' APUState a
l
        ((a -> Identity a) -> APUState -> Identity APUState)
-> (a -> a) -> APU r ()
forall s (m :: * -> *) a.
MonadState s m =>
ASetter' s a -> (a -> a) -> m ()
%= (LengthCounter -> LengthCounter) -> a -> a
forall a.
HasLengthCounter a =>
(LengthCounter -> LengthCounter) -> a -> a
withLengthCounter (if Bool
enable then LengthCounter -> LengthCounter
enableLengthCounter else LengthCounter -> LengthCounter
disableLengthCounter (LengthCounter -> LengthCounter)
-> (LengthCounter -> LengthCounter)
-> LengthCounter
-> LengthCounter
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LengthCounter -> LengthCounter
clearAndHaltLengthCounter)

{-# INLINE read4015 #-}
read4015 :: APU r Byte
read4015 :: forall r. APU r Byte
read4015 = do
    Bool
noiseBit <- Getting Noise APUState Noise -> (Noise -> Bool) -> APU r Bool
forall s (m :: * -> *) a r.
MonadState s m =>
Getting a s a -> (a -> r) -> m r
uses Getting Noise APUState Noise
Lens' APUState Noise
noise Noise -> Bool
forall {a}. HasLengthCounter a => a -> Bool
lengthCounterBit
    Bool
triangleBit <- Getting Triangle APUState Triangle
-> (Triangle -> Bool) -> APU r Bool
forall s (m :: * -> *) a r.
MonadState s m =>
Getting a s a -> (a -> r) -> m r
uses Getting Triangle APUState Triangle
Lens' APUState Triangle
triangle Triangle -> Bool
forall {a}. HasLengthCounter a => a -> Bool
lengthCounterBit
    Bool
pulse1Bit <- Getting Pulse APUState Pulse -> (Pulse -> Bool) -> APU r Bool
forall s (m :: * -> *) a r.
MonadState s m =>
Getting a s a -> (a -> r) -> m r
uses Getting Pulse APUState Pulse
Lens' APUState Pulse
pulse1 Pulse -> Bool
forall {a}. HasLengthCounter a => a -> Bool
lengthCounterBit
    Bool
pulse2Bit <- Getting Pulse APUState Pulse -> (Pulse -> Bool) -> APU r Bool
forall s (m :: * -> *) a r.
MonadState s m =>
Getting a s a -> (a -> r) -> m r
uses Getting Pulse APUState Pulse
Lens' APUState Pulse
pulse2 Pulse -> Bool
forall {a}. HasLengthCounter a => a -> Bool
lengthCounterBit
    Bool
dmcBit <- Getting DMC APUState DMC -> (DMC -> Bool) -> APU r Bool
forall s (m :: * -> *) a r.
MonadState s m =>
Getting a s a -> (a -> r) -> m r
uses Getting DMC APUState DMC
Lens' APUState DMC
dmc ((DMC -> Bool) -> APU r Bool) -> (DMC -> Bool) -> APU r Bool
forall a b. (a -> b) -> a -> b
$ \DMC
d -> DMC -> Int
sampleBytesRemaining DMC
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
    Bool
frameInterruptBit <- Getting FrameCounter APUState FrameCounter
-> (FrameCounter -> Bool) -> APU r Bool
forall s (m :: * -> *) a r.
MonadState s m =>
Getting a s a -> (a -> r) -> m r
uses Getting FrameCounter APUState FrameCounter
Lens' APUState FrameCounter
frameCounter FrameCounter -> Bool
frameInterruptFlag
    Bool
dmcInterruptBit <- (InterruptStatus -> Bool) -> APU r Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((InterruptStatus -> Bool) -> APU r Bool)
-> (InterruptStatus -> Bool) -> APU r Bool
forall a b. (a -> b) -> a -> b
$ (Maybe IRQSource -> Maybe IRQSource -> Bool
forall a. Eq a => a -> a -> Bool
== IRQSource -> Maybe IRQSource
forall a. a -> Maybe a
Just IRQSource
DMC) (Maybe IRQSource -> Bool)
-> (InterruptStatus -> Maybe IRQSource) -> InterruptStatus -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InterruptStatus -> Maybe IRQSource
irq
    -- TODO Clearing flag should be done on every GET cycle
    -- https://github.com/100thCoin/AccuracyCoin/blob/a7bf0cfaee7dee9e7bfbd0e30435b85cb539139e/AccuracyCoin.asm#L9003
    Bool -> APU r () -> APU r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
frameInterruptBit (APU r () -> APU r ()) -> APU r () -> APU r ()
forall a b. (a -> b) -> a -> b
$ do
        Bool -> APU r ()
forall r. Bool -> APU r ()
setFrameInterruptFlag Bool
False
    let res :: Byte
res =
            Bool -> Int -> Byte -> Byte
forall {a}. Bits a => Bool -> Int -> a -> a
setBit' Bool
dmcInterruptBit Int
7 (Byte -> Byte) -> Byte -> Byte
forall a b. (a -> b) -> a -> b
$
                Bool -> Int -> Byte -> Byte
forall {a}. Bits a => Bool -> Int -> a -> a
setBit' Bool
frameInterruptBit Int
6 (Byte -> Byte) -> Byte -> Byte
forall a b. (a -> b) -> a -> b
$
                    Bool -> Int -> Byte -> Byte
forall {a}. Bits a => Bool -> Int -> a -> a
setBit' Bool
dmcBit Int
4 (Byte -> Byte) -> Byte -> Byte
forall a b. (a -> b) -> a -> b
$
                        Bool -> Int -> Byte -> Byte
forall {a}. Bits a => Bool -> Int -> a -> a
setBit' Bool
noiseBit Int
3 (Byte -> Byte) -> Byte -> Byte
forall a b. (a -> b) -> a -> b
$
                            Bool -> Int -> Byte -> Byte
forall {a}. Bits a => Bool -> Int -> a -> a
setBit' Bool
triangleBit Int
2 (Byte -> Byte) -> Byte -> Byte
forall a b. (a -> b) -> a -> b
$
                                Bool -> Int -> Byte -> Byte
forall {a}. Bits a => Bool -> Int -> a -> a
setBit' Bool
pulse2Bit Int
1 (Byte -> Byte) -> Byte -> Byte
forall a b. (a -> b) -> a -> b
$
                                    Bool -> Int -> Byte -> Byte
forall {a}. Bits a => Bool -> Int -> a -> a
setBit'
                                        Bool
pulse1Bit
                                        Int
0
                                        Byte
0
    Byte -> APU r Byte
forall a. a -> APU r a
forall (m :: * -> *) a. Monad m => a -> m a
return Byte
res
  where
    setBit' :: Bool -> Int -> a -> a
setBit' Bool
b Int
i a
a = if Bool
b then a
a a -> Int -> a
forall a. Bits a => a -> Int -> a
`setBit` Int
i else a
a a -> Int -> a
forall a. Bits a => a -> Int -> a
`clearBit` Int
i
    lengthCounterBit :: a -> Bool
lengthCounterBit a
st =
        let lc :: LengthCounter
lc = a -> LengthCounter
forall a. HasLengthCounter a => a -> LengthCounter
getLengthCounter a
st
         in LengthCounter -> Bool
isEnabled LengthCounter
lc Bool -> Bool -> Bool
&& Bool -> Bool
not (a -> Bool
forall {a}. HasLengthCounter a => a -> Bool
isSilencedByLengthCounter a
st)