gistfile1.hs

{-# LANGUAGE LambdaCase, GeneralizedNewtypeDeriving #-}
{-# OPTIONS_GHC -Wall #-}
import Data.Array.IArray
import Debug.Trace

stream :: Array Int String
stream = listArray (0, length lst - 1) lst
  where
    lst = [ "(", "!", "string", "?", "string", ")", "?", "string" ]

data Session
    = S1 Fact Session
    | S2 Question
    | S3 Session Session
    deriving (Show)

data Fact = Fact String deriving (Show)

data Question = Question String deriving (Show)

boundsCheck idx f =
    if idx >= begin && idx <= end
      then f (stream ! idx)
      else Left Failure
  where
    (begin, end) = bounds stream

data Failure = Failure deriving (Show)

type ParseResult a = Either Failure a

question idx =
    boundsCheck idx $ \case
      "?" -> do
        (idx', s) <- string (idx + 1)
        return (idx', Question s)
      _ -> Left Failure

fact idx =
    boundsCheck idx $ \case
      "!" -> do
        (idx', s) <- string (idx + 1)
        return (idx', Fact s)
      _ -> Left Failure

string idx =
    boundsCheck idx $ \case
      "string" -> return (idx + 1, "string")
      _ -> Left Failure

token tok idx =
    boundsCheck idx $ \tok' ->
      if tok == tok' then return (idx + 1, tok) else Left Failure

session self idx =
    trace ("session called") $
    boundsCheck idx $ \case
      "!" -> do
        (idx', f) <- fact idx
        (idx'', ses) <- self idx'
        return (idx'', S1 f ses)
      "(" -> do
        (idx', ses) <- self (idx + 1)
        (idx'', _) <- token ")" idx'
        (idx''', ses') <- self idx''
        return (idx''', S3 ses ses')
      "?" -> do
        (idx', q) <- question idx
        return (idx', S2 q)
      _ -> Left Failure

fix f = let x = f x in x

sessionNonMemo = fix session

session_lst :: Array Int (ParseResult (Int, Session))
session_lst = fmap (session session_memo) (listArray (bounds stream) [0 .. snd (bounds stream)])

session_memo :: Int -> ParseResult (Int, Session)
session_memo n = session_lst ! n