First commit

10 files changed, 441 insertions, 0 deletions

diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..d861c7a
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,21 @@
+dist
+dist-*
+cabal-dev
+*.o
+*.hi
+*.chi
+*.chs.h
+*.dyn_o
+*.dyn_hi
+.hpc
+.hsenv
+.cabal-sandbox/
+cabal.sandbox.config
+*.prof
+*.aux
+*.hp
+*.eventlog
+.stack-work/
+cabal.project.local
+.HTF/
+.ghc.environment.*
\ No newline at end of file
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..1eb8bc4
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,30 @@
+Copyright Guillermo Ramos (c) 2017
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Guillermo Ramos nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
\ No newline at end of file
diff --git a/README.md b/README.md
new file mode 100644
index 0000000..3480092
--- /dev/null
+++ b/README.md
@@ -0,0 +1 @@
+# turing
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
index 0000000..9a994af
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/app/Main.hs b/app/Main.hs
new file mode 100644
index 0000000..01cf1e1
--- /dev/null
+++ b/app/Main.hs
@@ -0,0 +1,94 @@
+module Main where
+
+import Control.Concurrent (threadDelay)
+import Data.Maybe (fromMaybe)
+import Data.Monoid
+import System.IO (hFlush, stdout, isEOF)
+
+import Turing.Machine
+import Turing.Examples
+
+data Cmd = Exit | Run | Print | Help | Wait (Maybe Int) | Step Int
+data SimResult = Ok String | Error String deriving Show
+data SimState  = SimState { stMConf :: Config
+                          , stStopped :: Maybe SimResult
+                          , stWait :: Int }
+
+mkSimState :: Config -> SimState
+mkSimState conf = SimState conf Nothing 0
+
+stFailed, stUserStopped :: SimState -> SimState
+stFailed st = st { stStopped = Just (Error "Failed to do transition") }
+stUserStopped st = st { stStopped = Just (Ok "Stopped by user") }
+
+sim :: Machine -> Maybe Config -> IO SimResult
+sim m conf = prompt $ mkSimState (fromMaybe (mkConfig [SymSpace]) conf)
+    where
+      prompt st = do
+        putStr "> "
+        hFlush stdout
+        eof <- isEOF
+        if eof then return (Ok "Stopped by user")
+        else do
+          line <- getLine
+          case parseCmd (words line) of
+            Just cmd -> do st' <- execCmd st cmd
+                           case stStopped st' of
+                             Just how -> return how
+                             Nothing  -> prompt st'
+            Nothing  -> putStrLn "Unknown command (type 'h' for help)" >>
+                        prompt st
+
+      doSteps :: SimState -> Maybe Int -> IO SimState
+      doSteps st stop = if state (stMConf st) `elem` finals m || stop == Just 0
+                        then return st
+                        else case step (stMConf st) (delta m) of
+                               Nothing -> return $ stFailed st
+                               Just c' -> do print c'
+                                             threadDelay (stWait st)
+                                             let st' = st { stMConf = c' }
+                                             doSteps st' (fmap pred stop)
+
+      execCmd :: SimState -> Cmd -> IO SimState
+      execCmd st cmd =
+          case cmd of
+            Exit -> return (stUserStopped st)
+            Run -> doSteps st Nothing
+            Print -> print (stMConf st) >> return st
+            Help -> printHelp >> return st
+            Wait Nothing  -> putStrLn ("t = " ++ show (stWait st) ++ " µs") >>
+                             return st
+            Wait (Just t) -> let t' = 1000 * t in
+                             putStrLn ("t = " ++ show t' ++ " µs") >>
+                             return (st { stWait = t' })
+            Step n -> doSteps st (Just n)
+
+      parseCmd          :: [String] -> Maybe Cmd
+      parseCmd []       = Just (Step 1)
+      parseCmd ["q"]    = Just Exit
+      parseCmd ["r"]    = Just Run
+      parseCmd ["p"]    = Just Print
+      parseCmd ["h"]    = Just Help
+      parseCmd ["?"]    = Just Help
+      parseCmd ["t"]    = Just (Wait Nothing)
+      parseCmd ["t", n] = Just (Wait (Just (read n)))
+      parseCmd ["s", n] = Just (Step (read n))
+      parseCmd _        = Nothing
+
+      printHelp :: IO ()
+      printHelp = mapM_ (putStrLn . showCmd) cmds
+          where showCmd (cmd, desc) =
+                    cmd ++ replicate (gap - length cmd) ' ' ++ " - " ++ desc
+                cmds = [("q","exit the simulation")
+                       ,("r","run the simulation until it finishes")
+                       ,("p","print the machine")
+                       ,("h","print this help")
+                       ,("t [<n>]","print/set the current time interval")
+                       ,("s <n>","steps <n> times without prompting")]
+                gap = maximum (map (length . fst) cmds)
+
+main :: IO ()
+main = do
+  let example = mconcat [mWriteStr "_aaaaaa_aaa", mInit, mSub, mDecr]
+  print example
+  print =<< sim example Nothing
diff --git a/src/Turing/Examples.hs b/src/Turing/Examples.hs
new file mode 100644
index 0000000..3b113fd
--- /dev/null
+++ b/src/Turing/Examples.hs
@@ -0,0 +1,45 @@
+module Turing.Examples where
+
+import Data.List (intersperse)
+import Data.Monoid
+
+import Turing.Machine
+
+mR1, mL1, mInit :: Machine
+mR1 = mkMachine [(0, SymWild, R, 1)]
+mL1 = mkMachine [(0, SymWild, L, 1)]
+mInit = mL SymInit <> mR1
+
+mR, mL, mR', mL', mW :: Symbol -> Machine
+mR sy = mkMachine [(0, sy, W sy, 1), (0, SymWild, R, 0)]
+mL sy = mkMachine [(0, sy, W sy, 1), (0, SymWild, L, 0)]
+mR' sy = mkMachine [(0, sy, R, 0), (0, SymWild, W SymWild, 1)]
+mL' sy = mkMachine [(0, sy, L, 0), (0, SymWild, W SymWild, 1)]
+mW sy = mkMachine [(0, SymWild, W sy, 1)]
+
+mWriteStr :: String -> Machine
+mWriteStr = mconcat . intersperse mR1 . map (mW . charToSym)
+
+mSub :: Machine
+mSub = mkMachine [ (0, SymSpace,   R          , 1)
+                 , (1, Symbol 'a', R          , 1)
+                 , (1, SymSpace,   R          , 2)
+                 , (2, SymSpace,   R          , 2)
+                 , (2, Symbol 'a', R          , 3)
+                 , (3, SymSpace,   L          , 9)
+                 , (3, Symbol 'a', R          , 5)
+                 , (9, Symbol 'a', W SymSpace , 9)
+                 , (9, SymSpace,   L          , 4)
+                 , (4, SymInit,    R          , 10)
+                 , (4, SymWild,    L          , 4)
+                 , (5, Symbol 'a', R          , 5)
+                 , (5, SymSpace,   L          , 6)
+                 , (6, Symbol 'a', W SymSpace , 6)
+                 , (6, SymSpace,   L          , 7)
+                 , (7, Symbol 'a', L          , 7)
+                 , (7, SymSpace,   L          , 8)
+                 , (8, SymSpace,   L          , 8)
+                 , (8, Symbol 'a', W SymSpace , 2) ]
+
+mDecr :: Machine
+mDecr = mconcat [mR1, mR SymSpace, mL1, mW SymSpace, mL1, mL SymSpace]
diff --git a/src/Turing/Machine.hs b/src/Turing/Machine.hs
new file mode 100644
index 0000000..0a1002e
--- /dev/null
+++ b/src/Turing/Machine.hs
@@ -0,0 +1,137 @@
+module Turing.Machine where
+
+import qualified Data.Map.Strict as Map
+
+import Data.List
+import Data.Monoid
+import Control.Monad
+
+data Symbol = SymInit | SymWild | SymSpace | Symbol Char deriving (Eq, Ord)
+instance Show Symbol where
+    show (Symbol c) = [c]
+    show SymInit    = ">"
+    show SymWild    = "*"
+    show SymSpace   = "_"
+
+special :: Symbol -> Bool
+special (Symbol _) = False
+special _          = True
+
+charToSym :: Char -> Symbol
+charToSym '_' = SymSpace
+charToSym c = Symbol c
+
+data Action = W Symbol | L | R
+instance Show Action where
+    show (W sym) = show sym
+    show L       = "←"
+    show R       = "→"
+
+type State = Int
+type TransF = State -> Symbol -> Maybe (Action, State) -- TODO delete
+type Trans = Map.Map (State,Symbol) (Action,State)
+
+-- Turing Machine
+data Machine = Machine { states  :: [State]
+                       , s0      :: State
+                       , finals  :: [State]
+                       , symbols :: [Symbol]
+                       , delta   :: TransF
+                       , trans   :: Trans }
+instance Show Machine where
+    show (Machine sts ini fins syms _ trs) =
+        intercalate "\n\n"
+          [ "--- Turing Machine ---"
+          , " States: [" ++ show (head sts) ++ ".." ++ show (last sts) ++ "]"
+          , " Initial state: " ++ show ini
+          , " Final states: " ++ show fins
+          , " Symbols: " ++ show syms
+          , " Transition table:\n" ++ showTrans trs ]
+instance Monoid Machine where
+    mempty  = nop
+    mappend = comp
+
+showTrans :: Trans -> String
+showTrans trs = separator ++ intercalate' "\n" table ++ separator
+    where separator = " +" ++ concatMap (\s -> replicate s '-' ++ "--+") lengths
+          table = map (intercalate' " | "
+                       . map (\ (ml, f) -> replicate (ml - length f) ' ' ++ f)
+                       . zip lengths) fields
+          lengths = map (maximum . map length) (transpose fields)
+          fields = map (\ ((a, b), (c, d)) -> [show a, show b, show c, show d])
+                   (Map.toList trs)
+          intercalate' x xs = x ++ intercalate x xs ++ x
+
+mkDelta :: Trans -> TransF
+mkDelta trs st sym =
+    msum $ map (`Map.lookup` trs) [(st, sym), (st, SymWild)]
+
+mkMachine :: [(State, Symbol, Action, State)] -> Machine
+mkMachine trs = Machine sts ini fins syms (mkDelta trns) trns
+    where sts = sort $ union stsFrom stsTo
+          ini = minimum sts
+          fins = sort $ stsTo \\ stsFrom
+          syms = nub . filter (not . special) . map (\(_,sy,_,_) -> sy) $ trs
+          trns = Map.fromList (map (\(s1,sy,a,s2) -> ((s1,sy),(a,s2))) trs)
+          stsTo = nub $ map (\(_,_,_,s) -> s) trs
+          stsFrom = nub $ map (\(s,_,_,_) -> s) trs
+
+nop :: Machine
+nop = mkMachine [(0, SymWild, W SymWild, 1)]
+
+freshen :: Machine -> Machine -> Machine
+freshen m1 m2 = Machine sts ini fins syms d trns
+    where sts = map (+ offset) (states m2)
+          ini = s0 m2 + offset
+          fins = map (+ offset) (finals m2)
+          syms = symbols m2
+          d = mkDelta trns
+          trns = Map.map (\(a,s2) -> (a,s2+offset)) $
+                    Map.mapKeys (\(s1,sy) -> (s1+offset,sy)) (trans m2)
+          offset = maximum (states m1) + 1
+
+comp :: Machine -> Machine -> Machine
+comp m1 m2 = Machine sts ini fins syms d trns
+    where sts = sort $ states m1 `union` states m2'
+          ini = s0 m1
+          fins = finals m2'
+          syms = symbols m1 `union` symbols m2'
+          d st sym = msum $ map (\ s -> Map.lookup (st,s) trns) [sym, SymWild]
+          trns = Map.union connect $ Map.union (trans m1) (trans m2')
+          connect = Map.fromList $
+                    map (\ s1 -> ((s1,SymWild),(W SymWild, s0 m2'))) (finals m1)
+          m2' = freshen m1 m2
+
+-- Configuration
+type Tape = [Symbol]
+
+showTape :: Tape -> String
+showTape = concatMap show
+
+type Position = Int
+data Config = Config { tape  :: Tape
+                     , pos   :: Position
+                     , state :: State }
+instance Show Config where
+    show (Config t p s) = concat [roof, "\n|", showTape t, "\n", pointer, "\n"]
+        where roof = ' ' : replicate (length t) '_'
+              pointer = replicate (p+1) ' ' ++ "▲" ++ show s
+
+mkConfig :: Tape -> Config
+mkConfig t = Config (SymInit:t) 1 0
+
+step :: Config -> TransF -> Maybe Config
+step (Config t p s) d = fmap doAction (d s (t !! p))
+    where doAction (L, s') = Config (adjust t (p-1)) (p-1) s'
+          doAction (R, s') = Config (adjust t (p+1)) (p+1) s'
+          doAction (W sy, s')
+              | sy == SymWild = Config t p s'
+              | otherwise  = Config (adjust (replace t p sy) p) p s'
+          adjust l newpos
+              | diff > 0 = l ++ replicate diff SymSpace
+              | diff < 0 && last l == SymSpace = init l
+              | otherwise = l
+              where diff = newpos - (length l - 1)
+          replace [] _ _ = []
+          replace (_:xs) 0 e = e : xs
+          replace (x:xs) n e = x : replace xs (n-1) e
diff --git a/stack.yaml b/stack.yaml
new file mode 100644
index 0000000..26a9e7e
--- /dev/null
+++ b/stack.yaml
@@ -0,0 +1,66 @@
+# This file was automatically generated by 'stack init'
+#
+# Some commonly used options have been documented as comments in this file.
+# For advanced use and comprehensive documentation of the format, please see:
+# https://docs.haskellstack.org/en/stable/yaml_configuration/
+
+# Resolver to choose a 'specific' stackage snapshot or a compiler version.
+# A snapshot resolver dictates the compiler version and the set of packages
+# to be used for project dependencies. For example:
+#
+# resolver: lts-3.5
+# resolver: nightly-2015-09-21
+# resolver: ghc-7.10.2
+# resolver: ghcjs-0.1.0_ghc-7.10.2
+# resolver:
+#  name: custom-snapshot
+#  location: "./custom-snapshot.yaml"
+resolver: lts-9.3
+
+# User packages to be built.
+# Various formats can be used as shown in the example below.
+#
+# packages:
+# - some-directory
+# - https://example.com/foo/bar/baz-0.0.2.tar.gz
+# - location:
+#    git: https://github.com/commercialhaskell/stack.git
+#    commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
+# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
+#   extra-dep: true
+#  subdirs:
+#  - auto-update
+#  - wai
+#
+# A package marked 'extra-dep: true' will only be built if demanded by a
+# non-dependency (i.e. a user package), and its test suites and benchmarks
+# will not be run. This is useful for tweaking upstream packages.
+packages:
+- .
+# Dependency packages to be pulled from upstream that are not in the resolver
+# (e.g., acme-missiles-0.3)
+# extra-deps: []
+
+# Override default flag values for local packages and extra-deps
+# flags: {}
+
+# Extra package databases containing global packages
+# extra-package-dbs: []
+
+# Control whether we use the GHC we find on the path
+# system-ghc: true
+#
+# Require a specific version of stack, using version ranges
+# require-stack-version: -any # Default
+# require-stack-version: ">=1.5"
+#
+# Override the architecture used by stack, especially useful on Windows
+# arch: i386
+# arch: x86_64
+#
+# Extra directories used by stack for building
+# extra-include-dirs: [/path/to/dir]
+# extra-lib-dirs: [/path/to/dir]
+#
+# Allow a newer minor version of GHC than the snapshot specifies
+# compiler-check: newer-minor
diff --git a/test/Spec.hs b/test/Spec.hs
new file mode 100644
index 0000000..cd4753f
--- /dev/null
+++ b/test/Spec.hs
@@ -0,0 +1,2 @@
+main :: IO ()
+main = putStrLn "Test suite not yet implemented"
diff --git a/turing.cabal b/turing.cabal
new file mode 100644
index 0000000..12d0fab
--- /dev/null
+++ b/turing.cabal
@@ -0,0 +1,43 @@
+name:                turing
+version:             0.1.0.0
+-- synopsis:
+-- description:
+homepage:            https://turing.heimi.li
+license:             BSD3
+license-file:        LICENSE
+author:              Guillermo Ramos
+maintainer:          guillermo.ramos@imdea.org
+copyright:           2017 Guillermo Ramos
+category:            Math
+build-type:          Simple
+extra-source-files:  README.md
+cabal-version:       >=1.10
+
+library
+  hs-source-dirs:      src
+  exposed-modules:     Turing.Machine
+                     , Turing.Examples
+  build-depends:       base >= 4.7 && < 5
+                     , containers
+  default-language:    Haskell2010
+
+executable turing
+  hs-source-dirs:      app
+  main-is:             Main.hs
+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N
+  build-depends:       base
+                     , turing
+  default-language:    Haskell2010
+
+test-suite turing-test
+  type:                exitcode-stdio-1.0
+  hs-source-dirs:      test
+  main-is:             Spec.hs
+  build-depends:       base
+                     , turing
+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N
+  default-language:    Haskell2010
+
+-- source-repository head
+--   type:     git
+--   location: https://github.com/githubuser/turing