Commits

David Lazar committed dacfc4e

Import PCPL.

  • Participants

Comments (0)

Files changed (9)

+Copyright (c) 2012 David Lazar <lazar6@illinois.edu>
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in
+all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
+THE SOFTWARE.
+Name:               PCPL
+Version:            0.1.0
+Synopsis:           Post Correspondence Programming Language
+Homepage:           https://github.com/davidlazar/PCPL
+License:            MIT
+License-file:       LICENSE
+Author:             David Lazar
+Maintainer:         David Lazar <lazar6@illinois.edu>
+Category:           Language
+Build-type:         Simple
+Cabal-version:      >=1.6
+
+Extra-source-files:
+    README.md
+
+source-repository head
+  Type:             git
+  Location:         https://github.com/davidlazar/PCPL
+
+Library
+  ghc-options:      -Wall
+
+  Hs-source-dirs:   src
+
+  Exposed-modules:
+    Language.PCPL
+    Language.PCPL.Syntax
+    Language.PCPL.Pretty
+    Language.PCPL.Solver
+    Language.PCPL.CompileTM
+
+  Build-depends:
+    base >= 4 && < 5,
+    containers,
+    blaze-html,
+    utm
+# About
+
+The *Post Correspondence Programming Language* is my entry in the [Turing Tarpit PLT Games](http://www.pltgames.com/competition/2012/12).
+
+Please see my writeup: http://davidlazar.org/PCPL.html
+
+# Contributing
+
+This project is available on [GitHub](https://github.com/davidlazar/PCPL) and [Bitbucket](https://bitbucket.org/davidlazar/PCPL/). You may contribute changes using either.
+
+Please report bugs and feature requests using the [GitHub issue tracker](https://github.com/davidlazar/PCPL/issues).
+import Distribution.Simple
+main = defaultMain

src/Language/PCPL.hs

+{-# LANGUAGE OverloadedStrings #-}
+-- | Entry point to the Post Correspondence Programming Language
+module Language.PCPL
+    ( module Language.PCPL.Syntax
+    , module Language.PCPL.Pretty
+    , module Language.PCPL.CompileTM
+
+    -- * Execute PCPL programs
+    , runProgram
+
+    -- * Utility
+    , topString
+
+    -- * Examples
+    , unaryAdder
+    , parensMatcher 
+    ) where
+
+import qualified Data.Map as Map
+import Language.UTM.Syntax
+
+import Language.PCPL.Syntax
+import Language.PCPL.Pretty
+import Language.PCPL.Solver
+import Language.PCPL.CompileTM
+
+-- ^ Run a PCPL program on the given input, producing a PCP match.
+runProgram :: Program -> Input -> [Domino]
+runProgram pgm w = map (dss !!) indices
+  where
+    dss@(d : ds) = (startDomino pgm w) : dominos pgm
+    Just initialConfig = updateConf (Top []) d
+    indices = reverse $ search (zip [1..] ds) [Node [0] initialConfig]
+
+topString :: [Domino] -> String
+topString ds = concat [ s | Domino xs _ <- ds, Symbol s <- xs]
+
+unaryAdder :: TuringMachine
+unaryAdder = TuringMachine
+    { startState = "x"
+    , acceptState = "a"
+    , rejectState = "reject"
+    , blankSymbol = "_"
+    , inputAlphabet = ["1", "+"]
+    , transitionFunction = Map.fromList
+        [ (("x", "1"), ("x", "1", R))
+        , (("x", "+"), ("y", "1", R))
+        , (("y", "1"), ("y", "1", R))
+        , (("y", "_"), ("z", "_", L))
+        , (("z", "1"), ("a", "_", R))
+        , (("z", "+"), ("a", "_", R))
+        ]
+    }
+
+parensMatcher :: TuringMachine
+parensMatcher = TuringMachine
+    { startState = "S"
+    , acceptState = "Y"
+    , rejectState = "N"
+    , blankSymbol = " "
+    , inputAlphabet = syms "$()A"
+    , transitionFunction = Map.fromList
+        [ (("S", "$"), ("0", "$", R))
+
+        , (("0", "("), ("0", "(", R))
+        , (("0", ")"), ("1", "A", L))
+        , (("0", "A"), ("0", "A", R))
+        , (("0", " "), ("2", " ", L))
+        , (("1", "("), ("0", "A", R))
+        , (("1", "A"), ("1", "A", L))
+        --, (("1", "$"), ("N", "$", R))
+        --, (("2", "("), ("N", "(", R))
+        , (("2", "A"), ("2", "A", L))
+        --, (("N", "-"), ("N", "-", R))
+        , (("2", "$"), ("Y", "$", R))
+        ]
+    }

src/Language/PCPL/CompileTM.hs

+-- | This module implements the translation from Turing machines to PCP
+-- described in Sipser's /Theory of Computation/.
+module Language.PCPL.CompileTM
+    ( compileTM
+    , compileTM'
+    , Seperator
+    ) where
+
+import qualified Data.Map as Map
+import Language.UTM.Syntax
+import Language.PCPL.Syntax
+
+-- | Symbol used to separate TM configurations
+type Seperator = Symbol
+
+compileTM :: TuringMachine -> Program
+compileTM = compileTM' (Symbol "#")
+
+compileTM' :: Seperator -> TuringMachine -> Program
+compileTM' s tm = Program
+    { startDomino = part1 s tm
+    , dominos = concatMap (\f -> f s tm)
+        [part2, part3, part4, part5, part6, part7]
+    , separator = s
+    }
+
+part1 :: Seperator -> TuringMachine -> Input -> Domino 
+part1 s tm w = Domino [s] ([s, stateSymbol (startState tm)] ++ w ++ [s])
+
+part2 :: Seperator -> TuringMachine -> [Domino]
+part2 _ tm = Map.foldrWithKey actionR [] (transitionFunction tm)
+
+actionR :: (State, Symbol) -> (State, Symbol, Action) -> [Domino] -> [Domino]
+actionR (q, a) (r, b, R) ds = Domino [stateSymbol q, a] [b, stateSymbol r] : ds
+actionR _ _ ds = ds
+
+part3 :: Seperator -> TuringMachine -> [Domino]
+part3 _ tm = Map.foldrWithKey (actionL tm) [] (transitionFunction tm)
+
+actionL :: TuringMachine -> (State, Symbol) -> (State, Symbol, Action) -> [Domino] -> [Domino]
+actionL tm (q, a) (r, b, L) ds
+    = [Domino [c, stateSymbol q, a] [stateSymbol r, c, b] | c <- tapeAlphabet tm] ++ ds
+actionL _ _ _ ds = ds
+
+part4 :: Seperator -> TuringMachine -> [Domino]
+part4 _ tm = [Domino [a] [a] | a <- tapeAlphabet tm]
+
+part5 :: Seperator -> TuringMachine -> [Domino]
+part5 s tm = [Domino [s] [s], Domino [s] [blankSymbol tm, s]]
+
+part6 :: Seperator -> TuringMachine -> [Domino]
+part6 _ tm = concat [[Domino [a, q] [q], Domino [q, a] [q]] | a <- tapeAlphabet tm]
+  where
+    q = stateSymbol (acceptState tm)
+
+part7 :: Seperator -> TuringMachine -> [Domino]
+part7 s tm = [Domino [stateSymbol (acceptState tm), s, s] [s]]
+ 
+stateSymbol :: State -> Symbol
+stateSymbol (State s) = Symbol s

src/Language/PCPL/Pretty.hs

+{-# LANGUAGE OverloadedStrings #-}
+module Language.PCPL.Pretty where
+
+import Prelude hiding (div)
+import Data.List
+import Text.Blaze.Html5 hiding (map)
+import Text.Blaze.Html5.Attributes
+
+import Language.PCPL.Syntax
+
+class Pretty a where
+    pretty :: a -> String
+
+instance Pretty Domino where
+    pretty (Domino xs ys)
+        = "{" ++ unsyms xs ++ " | " ++ unsyms ys ++ "}"
+
+instance Pretty Program where
+    pretty pgm = intercalate ", " $ map pretty ds
+      where
+        ds = startDomino pgm ["$IN"] : dominos pgm
+
+instance Show Program where
+    showsPrec _ pgm = showString ("Program [" ++ pretty pgm ++ "]")
+
+instance ToMarkup Domino where
+    toMarkup (Domino xs ys) = div ! class_ "d" $ do
+        div (toMarkup $ unsyms xs)
+        div (toMarkup $ unsyms ys)
+
+instance ToMarkup Program where
+    toMarkup pgm = div ! class_ "pcp" $ mapM_ toMarkup ds
+      where
+        ds = startDomino pgm ["$IN"] : dominos pgm

src/Language/PCPL/Solver.hs

+-- | A simple PCP solver.
+-- There is a lot of potential for optimization here.
+module Language.PCPL.Solver
+    ( PCP
+    , Node(..)
+    , Configuration(..)
+    , search
+    , updateConf
+    ) where
+
+import Data.Maybe
+import Language.PCPL.Syntax
+
+-- | PCP instance
+type PCP = [(Int, Domino)]
+
+-- | Node in the search tree
+data Node = Node [Int] Configuration
+
+-- | The unmatched portion of an intermediate PCP state.
+-- The paper /Tackling Post's Correspondence Problem/
+-- calls this a configuration.
+data Configuration
+    = Top [Symbol]
+    -- ^ Portion of the top string that extends past the bottom one
+    | Bottom [Symbol]
+    -- ^ Portion of the bottom string that extends past the top one
+    deriving (Eq, Show)
+
+-- | Find a solution using BFS.
+search :: PCP -> [Node] -> [Int]
+search pcp level = case filter isSolution level of
+    [] -> search pcp cs
+    (Node is _:_) -> is
+  where
+    cs = concatMap (children pcp) level
+
+isSolution :: Node -> Bool
+isSolution (Node _ (Top [])) = True
+isSolution (Node _ (Bottom [])) = True
+isSolution _ = False
+
+children :: PCP -> Node -> [Node]
+children pcp n = mapMaybe (nextNode n) pcp
+
+nextNode :: Node -> (Int, Domino) -> Maybe Node
+nextNode (Node is c) (i, d) = case updateConf c d of
+    Nothing -> Nothing
+    Just c' -> Just $ Node (i : is) c'
+
+-- | Try to update the @Configuration@ with the given @Domino@.
+updateConf :: Configuration -> Domino -> Maybe Configuration
+updateConf (Top ts) (Domino xs ys) = reconfigure (Top $ ts ++ xs) (Bottom ys)
+updateConf (Bottom bs) (Domino xs ys) = reconfigure (Top xs) (Bottom $ bs ++ ys)
+
+reconfigure :: Configuration -> Configuration -> Maybe Configuration
+reconfigure (Top []) b = Just b
+reconfigure t (Bottom []) = Just t
+reconfigure (Top (x:xs)) (Bottom (y:ys))
+    | x == y = reconfigure (Top xs) (Bottom ys)
+    | otherwise = Nothing
+reconfigure (Bottom b) (Top t) = reconfigure (Top t) (Bottom b)

src/Language/PCPL/Syntax.hs

+module Language.PCPL.Syntax
+    ( Program(..)
+    , Domino(..)
+    , Symbol
+    , syms
+    , unsyms
+    ) where
+
+import Language.UTM.Syntax
+
+data Program = Program
+    { startDomino :: Input -> Domino
+    , dominos     :: [Domino]
+    , separator   :: Symbol
+    }
+
+data Domino = Domino [Symbol] [Symbol]
+    deriving (Eq, Show)