{-  An interpreter for the Argh! programming language in wxHaskell

    Copyright (C) 2007 Simeon Visser
    Contact: svisser@cs.uu.nl

    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 2 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, write to the Free Software
    Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
-}
{- |
An interpreter for the Argh! programming language in wxHaskell.
Argh! is an esoteric programming language created by Sascha Wilde. An Argh!
program is a two-dimensional grid (80x40 cells) and
each cell contains an integer that can be interpreted as such or
as a command that can be executed.
A stack is used to store values and to do calculations. For more information
about Argh!, see <http://www.sha-bang.de/index.php?page=12_eso> (in German).

This implementation (v0.8) is based on the following language specification:
<http://www.sha-bang.de/content/12_eso/Argh-Spec.txt>. All commands are
supported /except/ @e@ and @E@ (these are used for inserting EOF in cells).
Existing Argh! programs may or may not behave as expected: the @e@ and @E@
commands will produce an error and other language elements,
such as the @g@ and @G@ commands that use input from stdin
(a @TextEntry@ in this case), may also differ.

Available under the GNU General Public License. For more information,
see <http://www.gnu.org/licenses/>.

For more information about wxHaskell, see <http://wxhaskell.sourceforge.net/>.

Tested on Windows XP using GHCi 6.4.1 and wxHaskell 0.9.4. The window of the
program has a fixed size suited for 1024*768 resolution. This can be changed by removing
@resizeable := False@ in the 'interpreter' function yet the window still has
a minimum size because the @code@ widget has a minimum size. Of course, this
can be modified if you want to run it on 800*600 or lower.

Notes:

* Zero is considered to be both positive and negative when executing the @x@ and @X@
commands (see 'turnCond') - this is based on the fact that the @tenhello.agh@
example in the official Argh! distribution (version 0.2.3) would print /Hello world/
only 9 times if 0 is not considered a negative value.

* Checking the /Run even invalid code/ option doesn't turn this implementation
into Aargh! (that's Argh! without the maximum of 40 lines).
When checked, the interpreter will ignore the size limitations (80x40)
and\/or invalid characters and run anyway. The 'makeGrid' function makes use of the
'maxWidth' and 'maxHeight' constants so the grid might not have the expected size
if you use longer lines or more than the specified 40. As such, storing values in
non-existant cells will result in undefined behaviour. The option can be useful,
for example, when comments in the program contain invalid characters. Using it is
not recommended, however.

February 2007, Simeon Visser

For comments, bugs, etc: svisser\@cs.uu.nl
-}

-- module ArghInterpreter where
module Main where

import System.Directory (doesFileExist)
import Data.Char (chr, ord)
import Data.Maybe (listToMaybe, catMaybes)
import Data.List (intersperse, findIndices)
import Data.Ix (inRange)
import Graphics.UI.WX

-- * Data structures

data ArghStack
  = Stack [Int] -- ^ The stack.
  deriving (Show)
data ArghGrid
  -- | An Argh! program is a two-dimensional grid of 'ArghCell' elements.
  = Grid [[ArghCell]]
  deriving (Show)
data ArghCell
  -- | Every cell of the 'ArghGrid' can store an @Int@.
  = Cell Int
  -- | An existing but undefined cell (cells outside the 'ArghGrid' don't exist).
  | Undefined
  deriving (Show)

-- | Valid directions (control flow of an Argh! program).
data ArghDirection = ArghUp | ArghRight | ArghDown | ArghLeft
data ArghPointer
  -- | The pointer stores an 'ArghDirection' and a position (x,y).
  = Pointer ArghDirection Coordinate Coordinate
  deriving (Show)

instance (Show ArghDirection) where
  show ArghUp    = "Going up!\n"
  show ArghRight = "Going right!\n"
  show ArghDown  = "Going down!\n"
  show ArghLeft  = "Going left!\n"

type Coordinate = Int
type ErrorMessage = String
type ArghProgram = [String]

-- * Constants

-- | Version number.
version :: Float
version = 0.8

{- |
Maximum width; the interpreter complains when a line
is longer than this number of characters. Default maximum width is 80.
-}
maxWidth :: Int
maxWidth = 80

{- |
Maximum height; the interpreter complains when the program
consists of more than this number of lines. Default maximum height is 40.
-}
maxHeight :: Int
maxHeight = 40

{- |
This is used to specify the files the user can open in the Open dialogs.
-}
openFiles :: [(String,[String])]
openFiles =
  [ ("Argh! programs (*.agh)",["*.agh"])
  , ("Any file (*.*)",["*.*"]) ]

{- |
This is used to specify the files the user can save in the Save dialogs.
-}
saveFiles :: [(String,[String])]
saveFiles = [("Argh! programs (*.agh)", ["*.agh"])]

{- |
This is used to specify the output files.
-}
outputFiles :: [(String, [String])]
outputFiles =
  [ ("Text files (*.txt)", ["*.txt"])
  , ("Any file (*.*)",["*.*"]) ]

-- * Argh! interpreter

{- |
The main function. Call this to start the interpreter.
-}
main :: IO ()
main = start interpreter

{- |
The program; initializes variables to store state, creates the
controls for the user interface and creates the layout.
-}
interpreter :: IO ()
interpreter = do
   stack <- variable [ value := Stack [ ] ]

   -- variables
   bRunWithErrors <- variable [ value := False ]
   bShowLocation <- variable [ value := False ]
   bShowFullTrace <- variable [ value := False ]

   filepath <- variable [ value := "Default.agh" ]
   filepath' <- variable [ value := "Output.txt" ]

   -- the frame
   f <- frame [ text := ("Argh! interpreter v" ++ (show version))
              , resizeable := False ]

   -- text controls
   code <- textCtrlRich f [ font := fontFixed, wrap := WrapNone ]
   console <- textCtrlRich f [ font := fontFixed, wrap := WrapNone ]
   input <- textEntry f []

   -- the buttons
   check <- button f [ text := "Validate"
                     , on command := buttonCheckCode f code console
                     , tooltip := "Validates the current Argh! program " ]
   run <- button f [ text := "Run"
                   , on command := run code console input stack
                                   bRunWithErrors bShowLocation bShowFullTrace
                   , tooltip := "Runs the current Argh! program" ]

   -- checkboxes
   cb1 <- checkBox f [ text := "Run even invalid code (unsafe)"
                     , on command := set bRunWithErrors [ value :~ not ]
                     , tooltip := "Enable to allow execution of invalid code" ]
   cb2 <- checkBox f [ text := "Show location (x,y) when error occurs"
                     , on command := set bShowLocation [ value :~ not ]
                     , tooltip := "Enable to show the location in an error message" ]
   cb3 <- checkBox f [ text := "Output all executed commands"
                     , on command := set bShowFullTrace [ value :~ not ]
                     , tooltip := "Enable to output all executed commands"
                     ]

   -- statusbar
   status <- statusField []
   set f [ statusBar := [ status ] ]

   -- the menubar
   mfile <- makeFileMenu f filepath filepath' code console
   medit <- makeEditMenu f code
   mhelp <- makeHelpMenu f

   set f [ menuBar := [ mfile, medit, mhelp ] ]

   -- layout
   set f [ layout := margin 5 $ grid 5 5 $
            [ [ row 5 [ column 5 [ boxed "Argh!".fill.minsize (sz 550 300).widget $ code
                                 , boxed "Input".fill.widget $ input
                                 , boxed "Output".fill.widget $ console ]
              , column 5 [ boxed "Settings" $
                             column 5 [ alignCenter.row 5 $ [ widget run, widget check ]
                                      , widget cb1
                                      , widget cb2
                                      , widget cb3
                                      ]
                         ] ]
              ]
            ]
         ]

{- |
This function does preparations before the execution of the program begins (see
'exec'). It checks if the Argh! program is valid and creates an 'ArghGrid' to
execute the program using the settings specified by the variables (i.e., showing
error location yes\/no and outputting every command yes\/no).
-}
run :: TextCtrl () -> TextCtrl () -> TextCtrl () -> Var ArghStack -> Var Bool
        -> Var Bool -> Var Bool -> IO ()
run code console input vstack vbRunWithErrors vbShowLocation
      vbShowFullTrace = do
  txt <- get code text
  stack <- varGet vstack
  bRunWithErrors <- varGet vbRunWithErrors
  bShowLoc <- varGet vbShowLocation
  bShowFullTrace <- varGet vbShowFullTrace
  set console [ text := "" ]
  let program = lines txt
  case arghCompliant program of
     Just msg -> do
       case bRunWithErrors of
         False -> set console [ text := "Argh! invalid:\n" ++ msg ]
         True -> do
           let grid = makeGrid program
           input' <- get input text
           exec grid (Pointer ArghLeft 1 1) console input' stack bShowLoc bShowFullTrace
     Nothing -> do
       let grid = makeGrid program
       input' <- get input text
       exec grid (Pointer ArghLeft 1 1) console input' stack bShowLoc bShowFullTrace

{- |
The main loop. Reads the value from the current 'ArghCell', calls a function to execute
the command (if needed) and moves in the current execution direction.
-}
exec :: ArghGrid -> ArghPointer -> TextCtrl () -> String -> ArghStack -> Bool
     -> Bool -> IO ()
exec grid ptr@(Pointer dir x y) console input stack bShowLoc bShowFullTrace = do
  case getGrid grid x y of
    Just (Cell s) -> do
       case chr s of
          ' ' -> exec grid (move dir ptr) console input stack bShowLoc bShowFullTrace
          'q' -> set console [ text :~ (++ "\nProgram terminated succesfully.\n") ]
          'h' -> do if bShowFullTrace then appendText console (show ArghLeft) else return ()
                    exec grid (move ArghLeft ptr) console input stack bShowLoc bShowFullTrace
          'j' -> do if bShowFullTrace then appendText console (show ArghDown) else return ()
                    exec grid (move ArghDown ptr) console input stack bShowLoc bShowFullTrace
          'k' -> do if bShowFullTrace then appendText console (show ArghUp) else return ()
                    exec grid (move ArghUp ptr) console input stack bShowLoc bShowFullTrace
          'l' -> do if bShowFullTrace then appendText console (show ArghRight) else return ()
                    exec grid (move ArghRight ptr) console input stack bShowLoc bShowFullTrace
          'H' -> do if bShowFullTrace then appendText console "Going left, looking for value equal to value on top of stack!\n" else return ()
                    gridMove' grid (move ArghLeft ptr) console input stack bShowLoc bShowFullTrace
          'J' -> do if bShowFullTrace then appendText console "Going down, looking for value equal to value on top of stack!\n" else return ()
                    gridMove' grid (move ArghDown ptr) console input stack bShowLoc bShowFullTrace
          'K' -> do if bShowFullTrace then appendText console "Going up, looking for value equal to value on top of stack!\n" else return ()
                    gridMove' grid (move ArghUp ptr) console input stack bShowLoc bShowFullTrace
          'L' -> do if bShowFullTrace then appendText console "Going right, looking for value equal to value on top of stack!\n" else return ()
                    gridMove' grid (move ArghDown ptr) console input stack bShowLoc bShowFullTrace
          'x' -> do turnCond grid ptr console input stack bShowLoc (>= 0) turnRight bShowFullTrace
          'X' -> do turnCond grid ptr console input stack bShowLoc (<= 0)  turnLeft bShowFullTrace
          's' -> do store grid ptr console input stack bShowLoc (+1) bShowFullTrace
          'S' -> do store grid ptr console input stack bShowLoc ((+) (-1)) bShowFullTrace
          'd' -> do dupDel grid ptr console input stack bShowLoc dupl bShowFullTrace
          'D' -> do dupDel grid ptr console input stack bShowLoc delst bShowFullTrace
          'a' -> do addRed grid ptr console input stack bShowLoc (+1) addst bShowFullTrace
          'A' -> do addRed grid ptr console input stack bShowLoc ((+) (-1)) addst bShowFullTrace
          'r' -> do addRed grid ptr console input stack bShowLoc (+1) redst bShowFullTrace
          'R' -> do addRed grid ptr console input stack bShowLoc ((+) (-1)) redst  bShowFullTrace
          'f' -> do popStack grid ptr console input stack bShowLoc (+1) bShowFullTrace
          'F' -> do popStack grid ptr console input stack bShowLoc ((+) (-1)) bShowFullTrace
          'p' -> do showCell grid ptr console input stack bShowLoc (+1) bShowFullTrace
          'P' -> do showCell grid ptr console input stack bShowLoc ((+) (-1)) bShowFullTrace
          'g' -> do readStore grid ptr console input stack bShowLoc (+1) bShowFullTrace
          'G' -> do readStore grid ptr console input stack bShowLoc ((+) (-1)) bShowFullTrace
          '#' -> do
              case (x,y) == (1,1) of
                False -> arghError bShowLoc console x y
                True -> do
                  case getGrid grid 2 1 of
                    Just (Cell i) -> do
                      case i == ord '!' of
                        False -> arghError bShowLoc console x y
                        True -> exec grid (move ArghDown ptr) console input stack bShowLoc bShowFullTrace
                    _ -> arghError bShowLoc console x y
          _ -> do arghError bShowLoc console x y
    Just Undefined ->
      case validPos x y of
        False -> arghError bShowLoc console x y
        True -> exec grid (move dir ptr) console input stack bShowLoc bShowFullTrace
    _ -> arghError bShowLoc console x y

-- ** Command processing

{- |
Used for the @H@, @J@, @K@ and @L@ commands. It moves over the grid looking for
a specific value; it outputs an error if it's not found, else it'll continue the
execution of the program. The actual moving is done by 'gridMove'.
-}
gridMove' :: ArghGrid -> ArghPointer -> TextCtrl () -> String -> ArghStack
          -> Bool -> Bool -> IO ()
gridMove' grid ptr@(Pointer dir x y) console input stack bShowLoc bShowFullTrace = do
  case gridMove grid ptr (getTop stack) of
    Nothing -> arghError bShowLoc console x y
    Just (a,b) -> do
      if bShowFullTrace then appendText console "Found value!\n" else return ()
      exec grid (move dir (Pointer dir a b)) console input stack bShowLoc bShowFullTrace

{- |
Used for the @x@ and @X@ commands. It checks the value of the stack and turns
depending on a condition (the @Int -> Bool@ function). Zero is considered to be
both positive and negative. See the notes above for an explanation.
-}
turnCond
  :: ArghGrid
  -> ArghPointer
  -> TextCtrl () -- ^ The main @TextCtrl@ (containing the source code).
  -> String -- ^ The input (not the source code).
  -> ArghStack
  -> Bool -- ^ Show error location in error message yes\/no.
  -> (Int -> Bool) -- ^ The condition to turn (e.g., @(>= 0)@, @(<= 0)@).
  -> (ArghDirection -> ArghDirection) -- ^ Turning function (see 'turnLeft' and 'turnRight').
  -> Bool -- ^ Output all executed commands yes\/no.
  -> IO ()
turnCond grid ptr@(Pointer dir x y) console input stack bShowLoc cond f bShowFullTrace = do
  case getTop stack of
    Nothing -> arghError bShowLoc console x y
    Just n ->
      case cond n of
        False -> exec grid (move dir ptr) console input stack bShowLoc bShowFullTrace
        True -> do
          let newdir = f dir
          if bShowFullTrace then appendText console (show newdir) else return()
          exec grid (move newdir ptr) console input stack bShowLoc bShowFullTrace

{- |
Used for the @s@ and @S@ commands. Pushes the value in the 'ArghCell' above or below
the current one on the stack.
-}
store
  :: ArghGrid
  -> ArghPointer
  -> TextCtrl () -- ^ The main @TextCtrl@ (containing the source code).
  -> String -- ^ The input (not the source code).
  -> ArghStack
  -> Bool -- ^ Show error location in error message yes\/no.
  -> (Coordinate -> Coordinate) -- ^ Used to calculate new y-coordinate.
  -> Bool -- ^ Output all executed commands yes\/no.
  -> IO ()
store grid ptr@(Pointer dir x y) console input stack bShowLoc f bShowFullTrace = do
  case getGrid grid x (f y) of
    Just (Cell i) -> do
      let stack' = push stack i
      if bShowFullTrace then viewStack stack' console else return ()
      exec grid (move dir ptr) console input stack' bShowLoc bShowFullTrace
    _ -> arghError bShowLoc console x y


{- |
Used for the @d@ and @D@ commands. Duplicates or deletes the value on top off the
stack, if it exists.
-}
dupDel
  :: ArghGrid
  -> ArghPointer
  -> TextCtrl () -- ^ The main @TextCtrl@ (containing the source code).
  -> String -- ^ The input (not the source code).
  -> ArghStack
  -> Bool -- ^ Show error location in error message yes\/no.
  -> (ArghStack -> Maybe ArghStack) -- ^ The stack operation, see 'dupl' and 'delst'.
  -> Bool -- ^ Output all executed commands yes\/no.
  -> IO ()
dupDel grid ptr@(Pointer dir x y) console input stack bShowLoc f bShowFullTrace= do
  case f stack of
    Nothing -> arghError bShowLoc console x y
    Just stack' -> do
      if bShowFullTrace then viewStack stack' console else return ()
      exec grid (move dir ptr) console input stack' bShowLoc bShowFullTrace

{- |
Used for the @a@, @A@, @r@ and @R@ commands. Adds or reduces the value on top of
the stack with the value in the 'ArghCell' above or below the current one.
-}
addRed
  :: ArghGrid
  -> ArghPointer
  -> TextCtrl () -- ^ The main @TextCtrl@ (containing the source code).
  -> String -- ^ The input (not the source code).
  -> ArghStack
  -> Bool -- ^ Show error location in error message yes\/no.
  -> (Coordinate -> Coordinate) -- ^ Used to calculate the new y-coordinate.
  -> (ArghStack -> Int -> Maybe ArghStack) -- ^ The stack operation, see 'addst' and 'redst'.
  -> Bool -- ^ Output all executed commands yes\/no.
  -> IO ()
addRed grid ptr@(Pointer dir x y) console input stack bShowLoc f g bShowFullTrace = do
  case getGrid grid x (f y) of
    Just (Cell i) -> do
      case g stack i of
        Nothing -> arghError bShowLoc console x y
        Just stack' -> do
          if bShowFullTrace then viewStack stack' console else return ()
          exec grid (move dir ptr) console input stack' bShowLoc bShowFullTrace
    _ -> arghError bShowLoc console x y

{- |
Used for the @f@ and @F@ commands. Pops the value from the top of the stack
and stores it in the 'ArghCell' above or below the current one.
-}
popStack
  :: ArghGrid 
  -> ArghPointer
  -> TextCtrl () -- ^ The main @TextCtrl@ (containing the source code).
  -> String -- ^ The input (not the source code).
  -> ArghStack
  -> Bool -- ^ Show error location in error message yes\/no.
  -> (Coordinate -> Coordinate) -- ^ Used to calculate the new y-coordinate.
  -> Bool -- ^ Output all executed commands yes\/no.
  -> IO ()
popStack grid ptr@(Pointer dir x y) console input stack bShowLoc f bShowFullTrace= do
  let (pop', stack') = pop stack
  case pop' of
    Nothing -> arghError bShowLoc console x y
    Just i ->
      case validPos x (f y) of
        False -> do
          if bShowFullTrace then viewStack stack' console else return ()
          arghError bShowLoc console x y
        True ->
          case setGrid grid x (f y) i of
            Nothing -> do
              if bShowFullTrace then viewStack stack' console else return ()
              arghError bShowLoc console x y
            Just grid' -> do
              if bShowFullTrace then viewStack stack' console else return ()
              exec grid' (move dir ptr) console input stack' bShowLoc bShowFullTrace

{- |
Used for the @p@ and @P@ commands. Showing the value of the 'ArghCell' above
or below the current one.
-}
showCell
  :: ArghGrid
  -> ArghPointer
  -> TextCtrl () -- ^ The main @TextCtrl@ (containing the source code).
  -> String -- ^ The input (not the source code).
  -> ArghStack
  -> Bool -- ^ Show error location in error message yes\/no.
  -> (Coordinate -> Coordinate) -- ^ Used to calculate the new y-coordinate.
  -> Bool -- ^ Output all executed commands yes\/no.
  -> IO ()
showCell grid ptr@(Pointer dir x y) console input stack bShowLoc f bShowFullTrace = do
  case getGrid grid x (f y) of
    Just (Cell i) -> do
      let c = chr i
      appendText console [c]
      exec grid (move dir ptr) console input stack bShowLoc bShowFullTrace
    _ -> arghError bShowLoc console x y

{- |
Used for the @g@ and @G@ commands. Reads a value from the input (a @String@) and stores
it in the 'ArghCell' above or below the current one. It outputs an error if the input
is empty or if the 'ArghCell' above or below the current one doesn't exist.
-}
readStore
  :: ArghGrid
  -> ArghPointer
  -> TextCtrl () -- ^ The main @TextCtrl@ (containing the source code).
  -> String -- ^ The input (not the source code).
  -> ArghStack
  -> Bool -- ^ Show error location in error message yes\/no.
  -> (Coordinate -> Coordinate) -- ^ Used to calculate the new y-coordinate.
  -> Bool -- ^ Output all executed commands yes\/no.
  -> IO ()
readStore grid ptr@(Pointer dir x y) console input stack bShowLoc f bShowFullTrace = do
  case null input of
    True -> arghError bShowLoc console x y
    False -> do
      case getGrid grid x (f y) of
        Nothing -> arghError bShowLoc console x y
        _ -> do
          let value = ord.head $ input
          case setGrid grid x (f y) value of
            Nothing -> arghError bShowLoc console x y
            Just grid' -> do
              if bShowFullTrace then appendText console ("Storing: " ++ show value) else return ()
              exec grid' (move dir ptr) console (tail input) stack bShowLoc bShowFullTrace

-- | Returns an 'ArghPointer' that has been moved in the given 'ArghDirection'.
move :: ArghDirection -> ArghPointer -> ArghPointer
move ArghLeft  = move' ((+) (-1)) id ArghLeft
move ArghRight = move' ((+) 1) id    ArghRight
move ArghUp    = move' id ((+) (-1)) ArghUp
move ArghDown  = move' id ((+) 1)    ArghDown

{- |
Applies the two functions to the location of the 'ArghPointer'. It returns
a new 'ArghPointer' with the given 'ArghDirection' and the new position.
-}
move' :: (Coordinate -> Coordinate) -- ^ Will be applied to the x-coordinate.
      -> (Coordinate -> Coordinate) -- ^ Will be applied to the y-coordinate.
      -> ArghDirection -> ArghPointer -> ArghPointer
move' f g dir (Pointer _ x y) = (Pointer dir (f x) (g y))

-- ** Stack operations

-- | Returns the contents of an 'ArghStack'.
viewS :: ArghStack -> [Int]
viewS (Stack s) = s

-- | Outputs the contents of the 'ArghStack' to the specified @TextCtrl@.
viewStack :: ArghStack -> TextCtrl () -> IO ()
viewStack (Stack xs) console =
  appendText console ("Stack: " ++ show xs ++ "\n")

-- | Returns the value on top of the stack (@Just@), else @Nothing@.
getTop :: ArghStack -> Maybe Int
getTop = listToMaybe.viewS

-- | Pushes the value on the 'ArghStack'.
push :: ArghStack -> Int -> ArghStack
push s x = Stack (x : viewS s)

{- |
Pops the value off the 'ArghStack'. It returns the
popped value (if it exists) and the new stack.
-}
pop :: ArghStack -> (Maybe Int, ArghStack)
pop s@(Stack []) = (Nothing, s)
pop (Stack (x:xs)) = (Just x, Stack xs)

-- | Duplicates the value on top of the 'ArghStack', if it exists.
dupl :: ArghStack -> Maybe ArghStack
dupl (Stack xs) = checkToMaybe xs (Stack ((head xs):xs))

-- | Deletes the value on top of the 'ArghStack', if it exists.
delst :: ArghStack -> Maybe ArghStack
delst (Stack xs) = checkToMaybe xs (Stack (tail xs))

-- | Redures the value on top of the 'ArghStack', if it exists, by the given value.
redst :: ArghStack -> Int -> Maybe ArghStack
redst = opst (-)

-- | Add the given value to the value on top of the 'ArghStack', if it exists.
addst :: ArghStack -> Int -> Maybe ArghStack
addst = opst (+)

{- |
Applies the function and the value to the value on top of the 'ArghStack'.
Returns the new stack if succesful.
-}
opst :: (Int -> Int -> Int) -> ArghStack -> Int -> Maybe ArghStack
opst f (Stack xs) i = checkToMaybe xs (Stack ((f (head xs) i):(tail xs)))

-- ** Grid operations

{- |
Sets the value of a value in the 'ArghGrid'. It returns the new grid if
succesful.
-}
setGrid :: ArghGrid -> Coordinate -> Coordinate -> Int -> Maybe ArghGrid
setGrid grid@(Grid list) x y value =
  if not (validPos x y)
  then Nothing
  else
    case getRow grid y of
      Nothing -> Nothing
      Just l ->
        let newrow = [concat [(take (x-1) l), [(Cell value)], (drop x l)]]
        in let newlist = concat [(take (y-1) list), newrow, (drop y list)]
           in Just (Grid newlist)

{- |
Moves the 'ArghPointer' over the 'ArghGrid', looking for a specific value.
Returns the location of the cell where it is found, else @Nothing@.
-}
gridMove :: ArghGrid -> ArghPointer -> Maybe Int -> Maybe (Coordinate, Coordinate)
gridMove _ _ Nothing = Nothing
gridMove grid ptr@(Pointer dir x y) k@(Just value) =
 case getGrid grid x y of
   Just (Cell c) ->
     case c == value of
       True -> Just (x,y)
       False -> gridMove grid (move dir ptr) k
   _ -> Nothing

{- |
Creates an 'ArghGrid' for a given 'ArghProgram'. This function performs
no checks to see if the program is valid. Running the interpreter with an
invalid Argh! program could result in undefined behaviour. This function
makes use of the 'maxWidth' and 'maxHeight' constants so the produced
grid might not have the expected size when constructed from an
invalid 'ArghProgram'.
-}
makeGrid :: ArghProgram -> ArghGrid
makeGrid s = Grid z2
  where f = map ((.) Cell ord)
        g x = let i = length x in if i < maxHeight then x ++ k i else x
        k i = take (maxHeight-i) (repeat Undefined)
        z = map (g.f) s
        z2 = let j = length z in if j < maxWidth then z ++ replicate (maxWidth-j) (k 0) else z

{- |
Returns a row in the 'ArghGrid', if it exists.
-}
getRow :: ArghGrid -> Int -> Maybe [ArghCell]
getRow (Grid list) n = checkToMaybe' (not.inRange (1,maxWidth) $ n) (list !! (n-1))

{- |
Returns the value of a specific 'ArghCell' in the 'ArghGrid', if it exists.
-}
getGrid :: ArghGrid -> Coordinate -> Coordinate -> Maybe ArghCell
getGrid _ 0 _ = Nothing
getGrid _ _ 0 = Nothing
getGrid grid@(Grid list) x y =
  case getRow grid y of
    Nothing -> Nothing
    Just list ->
      let dropped = drop (x-1) list
      in checkToMaybe dropped (head dropped)

-- | Returns @True@ if it's a valid position (x,y).
validPos :: Coordinate -> Coordinate -> Bool
validPos x y = inRange (1,maxHeight) x && inRange (1,maxWidth) y

-- ** Code validation

{- |
Returns an 'ErrorMessage' if the specified @String@ (the Argh! program)
is invalid. This error message is a combination of the error messages produced
by 'checkHeight', 'checkWidth' and 'checkChar'.
-}
arghCompliant :: ArghProgram -> Maybe ErrorMessage
arghCompliant [] = Just "There's no program!"
arghCompliant s = checkToMaybe k k
  where k = concat.catMaybes $ [ isDir.head.head $ s, checkToMaybe l l ]
        l = concat.catMaybes $ [checkHeight s, checkWidth s, checkChar s]
        isDir x = checkToMaybe' (any (==x) "hjkl") string
        string = concat [ "Character at (1,1) doesn't specify an execution direction.\n"
                        , "Use 'h' for left, 'j' for down, 'k' for up or 'l' for right.\n" ]

{- |
Checks the width of the 'ArghProgram'.
-}
checkWidth :: ArghProgram -> Maybe ErrorMessage
checkWidth s = let k = checkLength.map length $ s in checkToMaybe k k

{- |
Checks the length of the list of @Int@ (each @Int@ is the length of a specific line).
-}
checkLength :: [Int] -> ErrorMessage
checkLength s =
  let f (a,b) = concat [ "Line ", show a, " has a length of "
                       , show b, " characters."]
  in unlines [ f x | x <- (zip [1..] s), (snd x) > maxWidth ]

{- |
Checks the height of the 'ArghProgram'. Returns
an 'ErrorMessage' if needed, else @Nothing@.
-}
checkHeight :: ArghProgram -> Maybe ErrorMessage
checkHeight s =
  let k = length s
  in checkToMaybe' (k <= maxWidth) (concat ["Too many lines: ", show k, ".\n"])

{- |
Checks a line for invalid characters. Returns an 'ErrorMessage' if needed,
else @Nothing@.
-}
checkLine :: String -> Maybe ErrorMessage
checkLine list = let x = g list in checkToMaybe x (j x)
  where j = concat.intersperse ", ".map show
        g = map (+1).findIndices (not.validChar)

{- |
Checks an 'ArghProgram' for invalid characters. Returns
an 'ErrorMessage' if needed, else @Nothing@.
-}
checkChar :: ArghProgram -> Maybe ErrorMessage
checkChar s = let k = checkChar' s in checkToMaybe k (unlines k)
  where checkChar' s =
         let f (a,b) = (a, checkLine b)
         in filter (not.null) $ [ checkChar2.f $ x | x <- (zip [1..] s) ]
        checkChar2 (_, Nothing) = ""
        checkChar2 (n, Just x) =
          concat [ "Invalid character(s) (Line: ", show n, ", Position(s): ", x, ")." ]

{- |
Returns @True@ for valid characters. Valid characters have ASCII value 32 - 127
or newline (10).
-}
validChar :: Char -> Bool
validChar c = let ordc = ord c in ordc >= 32 && ordc < 127 || ordc == 10

-- * Miscellaneous

-- | Returns @Just b@ if the list is not empty, else @Nothing@.
checkToMaybe :: [a] -> b -> Maybe b
checkToMaybe xs = checkToMaybe' (null xs)

-- | Returns @Just a@ if @False@, else @Nothing@.
checkToMaybe' :: Bool -> a -> Maybe a
checkToMaybe' True  _ = Nothing
checkToMaybe' False j = Just j

-- | Turns right.
turnRight :: ArghDirection -> ArghDirection
turnRight ArghUp    = ArghRight
turnRight ArghRight = ArghDown
turnRight ArghDown  = ArghLeft
turnRight ArghLeft  = ArghUp

-- | Turns left.
turnLeft :: ArghDirection -> ArghDirection
turnLeft = turnRight.turnRight.turnRight

-- * User interface

{- |
Restores the settings (font, wrapping) of the @TextCtrl@.
-}
restoreSettings :: TextCtrl () -> IO ()
restoreSettings code = set code [ text := "", font := fontFixed, wrap := WrapNone ]

{- |
Used for the /Validate/ button (outputs if the Argh! program is valid or not).
-}
buttonCheckCode :: Frame ()
                -> TextCtrl () -- ^ @TextCtrl@ containing the Argh! source code
                -> TextCtrl () -- ^ @TextCtrl@ containing the output.
                -> IO ()
buttonCheckCode f code console = do
   txt <- get code text
   case arghCompliant (lines txt) of
     Nothing -> set console [ text := "Argh! OK!" ]
     Just msg -> set console [ text := "Argh! invalid:\n" ++ msg ]

{- |
Outputs the Argh! error message. If the Bool value is True, it appends
the location (x,y) where the error occurred (the two Int parameters).
-}
arghError :: Bool -> TextCtrl () -> Coordinate -> Coordinate -> IO ()
arghError bShowLocation console x y =
  case bShowLocation of
    False -> set console [ text :~ (++ "Argh!") ]
    True ->
      let z = concat [ "Argh! (", show x, ",", show y, ")" ]
      in set console [ text :~ (++ z) ]

-- | Creates the File menu.
makeFileMenu :: Frame () -> Var String -> Var String
             -> TextCtrl () -> TextCtrl () -> IO (Menu ())
makeFileMenu f filepath filepath' code console = do
   mfile <- menuPane [ text := "&File" ]
   mnew <- menuItem mfile [ text := "&New\tCtrl+N"
                          , on command := onFileNew f filepath code
                          , help := "Create a new Argh! program" ]
   mopen <- menuItem mfile [ text := "&Open...\tCtrl+O"
                           , on command := onFileOpen f filepath code
                           , help := "Open an existing Argh! program" ]
   msave <- menuItem mfile [ text := "&Save\tCtrl+S"
                           , on command := onFileSave f filepath code
                           , help := "Save the current Argh! program" ]
   msaveas <- menuItem mfile [ text := "Save &as..."
                           , on command := onFileSaveAs f filepath code
                           , help := "Save the current Argh! program with a new name" ]
   menuLine mfile
   msaveoutput <- menuItem mfile [ text := "Save output"
                                 , on command := onFileSaveOutput f filepath' console
                                 , help := "Save the output" ]
   msaveoutputas <- menuItem mfile [ text := "Save output as..."
                                   , on command := onFileSaveOutputAs f filepath' console
                                   , help := "Save the output with a new name" ]
   menuLine mfile
   mquit <- menuQuit mfile [ on command := close f
                           , help := "Exit the program" ]
   return mfile

-- | Creates the Help menu.
makeHelpMenu :: Frame () -> IO (Menu ())
makeHelpMenu f = do
  mhelp <- menuPane [ text := "&Help" ]
  mabout <- menuAbout mhelp [ help := "About this Argh! interpreter"
                            , on command := onHelpAbout f ]
  return mhelp

-- | Creates the Edit menu.
makeEditMenu :: Frame () -> TextCtrl () -> IO (Menu ())
makeEditMenu f code = do
  medit <- menuPane [ text := "&Edit" ]
  mappend <- menuItem medit [ text := "&Append file..."
                            , on command := onEditAppend f code
                            , help := "Append the contents of a file" ]
  return medit

-- | Handles the New option in the File menu.
onFileNew :: Frame () -> Var String -> TextCtrl () -> IO ()
onFileNew f filepath code = do
  txt <- get code text
  case null txt of
    True -> return ()
    False -> do
      result <- confirmDialog f "Argh!" "The current Argh! program will be lost. Want to save?" True
      case result of
        False -> restoreSettings code
        True -> do
          filepath' <- get filepath value
          result <- fileSaveDialog f True True "Save Argh! program" saveFiles filepath' ""
          case result of
            Nothing -> return ()
            Just path -> do
              set filepath [ value := path ]
              writeFile path txt
              restoreSettings code

-- | Handles the Open option in the File menu.
onFileOpen :: Frame () -> Var String -> TextCtrl () -> IO ()
onFileOpen f filepath code = do
  result <- fileOpenDialog f True True "Open Argh! program" openFiles "" ""
  case result of
    Nothing -> return ()
    Just path -> do
      exists <- doesFileExist path
      case exists of
        False -> return ()
        True -> do
          contents <- readFile path
          restoreSettings code
          set code [ text := contents ]
          set filepath [ value := path ]

-- | Handles the Save option in the File menu.
onFileSave :: Frame () -> Var String -> TextCtrl () -> IO ()
onFileSave f filepath code = do
  txt <- get code text
  filepath' <- get filepath value
  writeFile filepath' txt

-- | Handles the Save as option in the File menu.
onFileSaveAs :: Frame () -> Var String -> TextCtrl () -> IO ()
onFileSaveAs f filepath code = do
  txt <- get code text
  filepath' <- get filepath value
  result <- fileSaveDialog f True True "Save Argh! program" saveFiles filepath' ""
  case result of
    Nothing -> return ()
    Just path -> do
      set filepath [ value := path ]
      writeFile path txt

-- | Handles the Save output option in the File menu.
onFileSaveOutput :: Frame () -> Var String -> TextCtrl () -> IO ()
onFileSaveOutput f filepath console = do
  output <- get console text
  filepath' <- get filepath value
  writeFile filepath' output

-- | Handles the Save output as option in the File menu.
onFileSaveOutputAs :: Frame () -> Var String -> TextCtrl () -> IO ()
onFileSaveOutputAs f filepath console = do
  output <- get console text
  filepath' <- get filepath value
  result <- fileSaveDialog f True True "Save output" outputFiles filepath' ""
  case result of
    Nothing -> return ()
    Just path -> do
      set filepath [ value := path ]
      writeFile path output

-- | Handles the Append output option in the Edit menu.
onEditAppend :: Frame () -> TextCtrl () -> IO ()
onEditAppend f code = do
  result <- fileOpenDialog f True True "Append file" openFiles "" ""
  case result of
    Nothing -> return ()
    Just path -> do
      exists <- doesFileExist path
      case exists of
        False -> return ()
        True -> do
          currentCode <- get code text
          contents <- readFile path
          restoreSettings code
          set code [ text := (currentCode ++ contents) ]

-- | Handles the About option in the Help menu.
onHelpAbout :: Frame () -> IO ()
onHelpAbout f = do
  let string = unlines [ "Version " ++ show version ++ " - Created by Simeon Visser, February 2007."
                       , ""
                       , "For more information, see included readme and documentation."
                       , ""
                       , "Available under the GNU General Public License." ]
  infoDialog f "About this Argh! interpreter" string