pushdown.hs

{-# LANGUAGE TypeFamilies #-}

import Control.Monad (mzero)

class Pushdown m where
  data State m :: *
  data Sigma m :: *
  data Gamma m :: *
  
  startState :: State m
  startGamma :: Gamma m
  
  delta :: ID m -> [ID m]
  
  endState :: State m -> Bool

-- instantaneous description
type ID m = (State m, [Sigma m], [Gamma m])

endID :: Pushdown m => ID m -> Bool

endID (q, xs, ps) = null ps || endState q && null xs

runPushdown :: Pushdown m => [Sigma m] -> [ID m]

runPushdown xs =
  go [(startState, xs, [startGamma])]
  where
    go ids = do
      id@(_, _, ps) <- ids
      case go $ delta id of
        [] ->
          if endID id then
            return id
          else
            mzero
        ids' ->
          go ids'

---

data IdenC

mayusculas = map Carac $ ['A'..'Z']
minusculas = map Carac $ ['a'..'z']
letra = minusculas ++ mayusculas
digito = map Carac $ ['0'..'9']
sigma = Carac '_' : digito ++ letra

instance Pushdown IdenC where
  data    State IdenC = Q1 | Q2    deriving Show
  newtype Sigma IdenC = Carac Char deriving (Show, Eq)
  data    Gamma IdenC = Z          deriving Show
  
  startState = Q1
  startGamma = Z
  
  delta (Q1, x:xs, ps)
    | x `elem` letra = [(Q2, xs, ps)]

  delta (Q2, x:xs, ps)
    | x `elem` sigma = [(Q2, xs, ps)]

  delta (Q2, [], Z:ps) = [(Q2, [], ps)]

  delta _ = []
  
  endState _ = False