{-
    This source file is a part of the noisefunge programming environment.

    Copyright (C) 2015 Rev. Johnny Healey <rev.null@gmail.com>

    This program is free software: you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation, either version 3 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program.  If not, see <http://www.gnu.org/licenses/>.
-}

{-# LANGUAGE TemplateHaskell #-}

module Language.NoiseFunge.Befunge.Process (ProgArray, makeProgArray,
                                            Dir(..), PC(PC),
                                            Event(..),
                                            pos, dir, Pos,
                                            Delta(..), oldpc, newpc,
                                            change, events,
                                            ProcessState, makeProcessState,
                                            Stack, pop, (#+), stackLength,
                                            mem, pc, stack, quote,
                                            jump, progIn, progOut,
                                            fnStack,
                                            noteBuf, ticks,
                                            OperatorParams(..),
                                            Fungine, FungeVM,
                                            FungeProcess, FungeProgram,
                                            Deltas, ProcessStats,
                                            psTicks, psStackSize,
                                            psQuote,
                                            Operator(..),
                                            opCode, opChar,
                                            opName, opDesc,
                                            OpSet(..),
                                            processStats,
                                            tellDelta, tellMem
                                            ) where

import Control.Lens
import Control.Monad
import Control.Monad.RWS

import qualified Data.Array as Arr
import Data.Array.Unboxed
import qualified Data.Binary as B
import Data.Char
import Data.Default
import Data.Word

import Language.NoiseFunge.Befunge.VM
import Language.NoiseFunge.Note

-- This module builds upon the VM code to generate processes that are distinct
-- to the noisefunge engine. This provides the underlying functionality that
-- the operators are built around. It includes things such as the program
-- counter, stack, and process memory.

type Pos = (Word8, Word8)

type ProgArray = UArray Pos Word8

-- Convert a list of lines into a program array. The height will be the number
-- of lines and the width will be the length of the longest line.
makeProgArray :: [String] -> ProgArray
makeProgArray strs = arr where
    rows = fromIntegral $ length strs
    cols = fromIntegral $ maximum $ fmap length strs
    bnds = ((0,0), (rows-1, cols-1))
    arr = array bnds $ do
        (r, row) <- zip [0..] strs
        (c, char) <- zip [0..cols-1] (row ++ pad) 
        return ((r,c), fromIntegral $ ord char)
    pad = repeat ' '

data Dir = U | D | L | R
    deriving (Read, Show, Eq, Ord, Enum)

instance B.Binary Dir where
    get = (toEnum . fromIntegral) <$> B.getWord8
    put = B.putWord8 . fromIntegral . fromEnum 

data PC = PC {
    _pos :: !Pos,
    _dir :: !Dir
    } deriving (Read, Show, Eq, Ord)

instance Default PC where
    def = PC (0,0) R

instance B.Binary PC where
    get = PC <$> B.get <*> B.get
    put (PC p d) = B.put p >> B.put d

data Event =
    StringEvent String
  | ErrorEvent String
  | NoteEvent !Note
  deriving (Read, Show, Eq, Ord)

instance B.Binary Event where
    get = B.getWord8 >>= getEv where
        getEv 0 = StringEvent <$> B.get
        getEv 1 = ErrorEvent <$> B.get
        getEv 2 = NoteEvent <$> B.get
        getEv _ = error "Bad event"
    put (StringEvent s) = B.putWord8 0 >> B.put s
    put (ErrorEvent s) = B.putWord8 1 >> B.put s
    put (NoteEvent n) = B.putWord8 2 >> B.put n

-- A delta expresses how a process has changed in the last tick.
data Delta = Delta {
    _oldpc  :: Maybe PC,
    _newpc  :: Maybe PC,
    _change :: Maybe ProgArray,
    _events :: [Event]
    } deriving (Show, Eq, Ord)

instance Semigroup Delta where
    (<>) = mappend

instance Monoid Delta where
    mempty = Delta Nothing Nothing Nothing []
    mappend (Delta op1 np1 c1 e1) (Delta op2 np2 c2 e2) =
        Delta (op1 `mplus` op2) (np2 `mplus` np1)
            (c2 `mplus` c1) (e1 `mappend` e2)

instance B.Binary Delta where
    get = Delta <$> B.get <*> B.get <*> B.get <*> B.get
    put (Delta a b c d) = B.put a >> B.put b >> B.put c >> B.put d

instance Default Delta where
    def = mempty

type Deltas s = [(PID, s, Delta)] -> [(PID, s, Delta)]

data Stack a = Stack !Word32 [a]
    deriving (Read, Show, Eq, Ord)

instance Semigroup (Stack a) where
    (<>) = mappend

instance Monoid (Stack a) where
    mempty = Stack 0 []
    mappend (Stack xl xs) (Stack yl ys) = Stack (xl + yl) (xs ++ ys)

(#+) :: a -> Stack a -> Stack a
a #+ Stack l xs = Stack (l+1) (a:xs)

pop :: Stack a -> Maybe (a, Stack a)
pop (Stack 0 []) = Nothing
pop (Stack 0 _) = error "Invalid stack length"
pop (Stack _ []) = error "Invalid stack contents"
pop (Stack l (x:xs)) = Just (x, Stack (l-1) xs)

stackLength :: Stack a -> Word32
stackLength (Stack l _) = l

data ProcessState = PS {
    _mem     :: !ProgArray,
    _ticks   :: !Word32,
    _pc      :: !PC,
    _stack   :: !(Stack Word8),
    _quote   :: !Bool,
    _jump    :: !Bool,
    _fnStack :: !(Maybe [Word8]),
    _progIn  :: !String, -- Name of input buffer
    _progOut :: !String, -- Name of output buffer
    _noteBuf :: !(Maybe Note)
    }

makeProcessState :: ProgArray -> String -> String -> ProcessState
makeProcessState arr inp outp =
    PS arr 0 def mempty False False mempty inp outp Nothing

-- OperatorParams provides some options for how noisefunge operators should
-- behave.
data OperatorParams = OperatorParams {
    haltOnError :: !Bool,
    wrapOnEdge :: !Bool,
    debugLogging :: !Bool
  } deriving (Read, Show, Eq, Ord)

instance Default OperatorParams where
    def = OperatorParams True False False

data Operator = Operator {
    _opName :: String,
    _opChar :: Char,
    _opDesc :: String,
    _opCode :: (Fungine ())
  }

newtype OpSet = OpSet { getOpSet :: Arr.Array Word8 (Maybe (Fungine ())) }

type FungeRWS = RWS OperatorParams (Deltas ProcessState) OpSet

type Fungine = ProcessStateT Word8 ProcessState FungeRWS

type FungeVM = VM Word8 ProcessState FungeRWS

type FungeProcess = Process Word8 ProcessState FungeRWS

type FungeProgram = Program Word8 ProcessState FungeRWS

$(makeLenses ''ProcessState)
$(makeLenses ''Delta)
$(makeLenses ''PC)
$(makeLenses ''Operator)

tellDelta :: Delta -> Fungine ()
tellDelta d = do
    pid <- getPID
    st <- getProcessState
    tell ((pid, st, d):)

tellMem :: Fungine ()
tellMem = do
    arr <- use mem
    tellDelta $ Delta Nothing Nothing (Just arr) []

data ProcessStats = PStats {
    _psTicks     :: !Word32,
    _psStackSize :: !Word32,
    _psQuote     :: !Bool
  } deriving (Show, Eq, Ord)

$(makeLenses ''ProcessStats)

instance B.Binary ProcessStats where
    get = PStats <$> B.get <*> B.get <*> B.get
    put (PStats a b c) = B.put a >> B.put b >> B.put c

processStats :: Getter ProcessState ProcessStats
processStats = to processStats' where
    processStats' ps = PStats (ps^.ticks) (stackLength $ ps^.stack)
        (ps^.quote )

