nock.hs

import Text.ParserCombinators.Parsec
import Control.Monad

import System.IO (hFlush, hPutStr, hPutStrLn, hGetLine, stdin, stdout)

-- Parser

data Val = Op Char Val
         | Atom Int
         | Cell Val Val
  deriving (Eq)

instance Show Val where
  show (Op op args) = show op ++ show args
  show (Atom sym) = show sym
  show (Cell x y) = "[" ++ show x ++ " " ++ show y ++ "]"

maybeSpaceP :: Parser String
maybeSpaceP = many $ oneOf " \n\t"

spaceP :: Parser String
spaceP = many1 $ oneOf " \n\t"

opP :: Parser Val
opP = do opc <- oneOf "?+=/*"
         arg <- rawExprP
         pure (Op opc arg)

digitP :: Parser Char
digitP = oneOf ['0'..'9']

digitsP :: Parser String
digitsP = many1 digitP

atomP :: Parser Val
atomP = Atom . read <$> digitsP

cellP :: Parser Val
cellP = do char '[' >> maybeSpaceP
           result <- rawExprP `sepEndBy` maybeSpaceP
           maybeSpaceP >> char ']'
           pure $ aux result
             where aux [a, b] = Cell a b
                   aux (a:as) = Cell a $ aux as

rawExprP :: Parser Val
rawExprP = opP <|> atomP <|> cellP <?> "a value"

exprP :: Parser Val
exprP = between maybeSpaceP maybeSpaceP rawExprP <* eof

-- eval

eval :: Val -> Val

list2cell :: [Val] -> Val
list2cell [x, y] = Cell x y
list2cell (x:xs) = Cell x $ list2cell xs

eval expr@(Atom _) = expr
eval (Cell a b) = Cell (eval a) (eval b)

eval (Op '?' arg) = case eval arg of
  Cell _ _ -> Atom 0
  Atom _ -> Atom 1

eval (Op '+' arg) = case eval arg of
  res@(Cell _ _) -> res
  Atom a -> Atom $ 1 + a

eval (Op '=' arg) = case eval arg of
  Cell a b -> if a == b then Atom 0 else Atom 1
  res@(Atom a) -> res

eval (Op '/' arg) = case eval arg of
  Cell (Atom 1) a -> eval a
  Cell (Atom 2) (Cell a b) -> eval a
  Cell (Atom 3) (Cell a b) -> eval b
  Cell (Atom a) b -> eval (Op '/' (Cell
                                   (Atom (2 + (a `mod` 2)))
                                   (Op '/' (Cell (Atom (a `div` 2)) (eval b)))))
  res@(Atom _) -> res

eval (Op '*' arg) = case eval arg of
  Cell a (Cell (Cell b c) d) ->
    eval (Cell
          (Op '*' (Cell a (Cell b c)))
          (Op '*' (Cell a d)))
  Cell a (Cell (Atom 0) b) -> eval (Op '/' (Cell b a))
  Cell a (Cell (Atom 1) b) -> eval b
  Cell a (Cell (Atom 2) (Cell b c)) -> 
    eval (Op '*' (Cell
                  (Op '*' (Cell a b))
                  (Op '*' (Cell a c))))
  Cell a (Cell (Atom 3) b) -> eval (Op '?' (Op '*' (Cell a b)))
  Cell a (Cell (Atom 4) b) -> eval (Op '+' (Op '*' (Cell a b)))
  Cell a (Cell (Atom 5) b) -> eval (Op '=' (Op '*' (Cell a b)))
  
  -- *[a 6 b c d]     *[a 2 [0 1] 2 [1 c d] [1 0] 2 [1 2 3] [1 0] 4 4 b]
  Cell a (Cell (Atom 6) (Cell b (Cell c d))) ->
    eval (Op '*' $ list2cell [a
                             , Atom 2
                             , Cell (Atom 0) (Atom 1)
                             , Atom 2
                             , Cell (Atom 1) (Cell c d)
                             , Cell (Atom 1) (Atom 0)
                             , Atom 2
                             , Cell (Atom 1) (Cell (Atom 2) (Atom 3))
                             , Cell (Atom 1) (Atom 0)
                             , Atom 4
                             , Atom 4
                             , b])
  
  -- *[a 7 b c]       *[a 2 b 1 c]
  Cell a (Cell (Atom 7) (Cell b c)) ->
    eval (Op '*' $ list2cell [a, Atom 2, b, Atom 1, c])
  
  -- *[a 8 b c]       *[a 7 [[7 [0 1] b] 0 1] c]
  Cell a (Cell (Atom 8) (Cell b c)) ->
    eval (Op '*' $ list2cell [a
                             , Atom 7
                             , list2cell [
                                 list2cell [Atom 7, (Cell (Atom 0) (Atom 1)), b]
                                 , Atom 0, Atom 1]
                             , c])
  
  -- *[a 9 b c]       *[a 7 c 2 [0 1] 0 b]
  Cell a (Cell (Atom 9) (Cell b c)) ->
    eval (Op '*' $ list2cell [a
                             , Atom 7
                             , c
                             , Atom 2
                             , Cell (Atom 0) (Atom 1)
                             , Atom 0
                             , b])
  
  -- *[a 10 [b c] d]  *[a 8 c 7 [0 3] d]
  Cell a (Cell (Atom 10) (Cell (Cell b c) d)) ->
    eval (Op '*' $ list2cell [a
                             , Atom 8
                             , c
                             , Atom 7
                             , Cell (Atom 0) (Atom 3)
                             , d])
  
  -- *[a 10 b c]      *[a c]
  Cell a (Cell (Atom 10) (Cell b c)) -> eval (Op '*' (Cell a c))
  
  -- *a               *a
  a -> (Op '*' a)

-- REPL

printLn :: String -> IO ()
printLn str = hPutStrLn stdout str >> hFlush stdout

main :: IO ()
main = do
  putStr "*> "
  l <- getLine
  case parse exprP "Expression" l of
    Left err -> print err
    Right expr -> print $ eval expr
  main