Moore machines

moore/README.md

@@ -0,0 +1,5 @@
+Moore machines
+==============
+
+Some code to generate Moore machines. Especially the ones
+by the Rivest and Schapire papers. Enjoy!

moore/Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

moore/app/Main.hs

@@ -0,0 +1,11 @@
+module Main where
+
+import Gridworld (dotgraph)
+import Registerworld (dotgraph)
+import Crossword (dotgraph)
+
+main :: IO ()
+main = do
+  --mapM_ (\n -> writeFile ("output/register" ++ show n ++ ".dot") (Registerworld.dotgraph n)) [2..16]
+  --mapM_ (\(w,h) -> writeFile ("output/grid" ++ show w ++ "x" ++ show h ++ ".dot") (Gridworld.dotgraph w h)) [(2,2), (2,3), (2,4), (2,5), (3,3), (3,4)]
+  mapM_ (\(w,h) -> writeFile ("output/crossword" ++ show w ++ "x" ++ show h ++ ".dot") (Crossword.dotgraph w h)) . fmap (\x -> (x, x)) $ [2..12]

moore/moore.cabal

@@ -0,0 +1,28 @@
+cabal-version:  2.2
+name:           moore
+version:        0.1.0.0
+author:         Joshua Moerman
+
+extra-source-files:
+  README.md
+
+common stuff
+  default-language: Haskell2010
+  ghc-options: -O2 -Wall
+  build-depends:
+    base >= 4.8 && < 5,
+    containers
+
+library
+  import: stuff
+  hs-source-dirs: src
+  exposed-modules:
+    Gridworld,
+    Registerworld,
+    Crossword
+
+executable moore
+  import: stuff
+  main-is: Main.hs
+  hs-source-dirs: app
+  build-depends: moore

moore/src/Crossword.hs

@@ -0,0 +1,152 @@
+module Crossword where
+
+{-
+
+From the Rivest and Schapire homing sequence paper:
+
+" In the "Crossword Puzzle" environment, the robot is on a crossword puzzle
+  grid. The robot has three actions available to it: it can step ahead one
+  square, or it can turn left or right by 90 degrees. The robot can only
+  occupy the white squares of the crossword puzzle; an attempt to move onto
+  a black square is a "no-op." Attempting to step beyond the boundaries of
+  the puzzle is also a no-op. Each of the four "walls" of the puzzle has
+  been painted a different color. The robot looks as far ahead as possible
+  in the direction it faces: if its view is obstructed by a black square,
+  then it sees "black;" otherwise, it sees the color of the wall it is
+  facing. Thus, the robot has five possible sensations. Since this
+  environment is essentially a maze, it may contain regions which are
+  difficult to reach or difficult to get out of. "
+
+-}
+
+import Data.List (delete)
+import Data.Set (Set)
+import qualified Data.Set as Set
+
+-- Four directions and blocked view
+data Output = N | W | S | E | X
+  deriving (Show, Eq)
+
+data Alphabet = F | R | L
+  deriving (Show, Eq)
+
+-- Location and direction (taken from the Output type)
+-- X is not a valid direction. Location is Row x Column
+type Loc = (Int, Int)
+type State = ((Int, Int), Output)
+
+-- We represent the walls and size of the world. Width x Height
+type World = (Int, Int, Set Loc)
+type WorldData = [[Bool]]
+
+t, f :: Bool
+t = True
+f = False
+
+-- The upper top-left 8x8 block is from the paper. The rest
+-- I made up. However, the number of walls is correct for 12x12.
+worldCxC :: WorldData
+worldCxC = [ [ f, f, t, t, t, t, t, t,   f, f, f, f ]
+           , [ t, t, t, t, f, t, t, t,   f, t, f, f ]
+           , [ t, t, t, f, t, t, t, t,   t, t, t, t ]
+           , [ t, f, t, t, t, f, t, t,   t, f, t, t ]
+           , [ t, f, t, t, t, t, f, t,   t, t, f, t ]
+           , [ t, t, f, t, t, t, f, t,   t, t, f, t ]
+           , [ t, t, f, t, t, t, t, t,   t, t, t, t ]
+           , [ f, t, t, t, t, t, t, t,   t, t, t, t ]
+
+           , [ f, t, t, t, t, t, t, t,   t, t, t, t ]
+           , [ t, f, t, t, f, f, f, f,   f, f, f, f ]
+           , [ t, f, t, t, f, f, f, f,   f, f, f, t ]
+           , [ t, t, t, t, t, t, t, t,   t, t, t, t ]
+           ]
+
+worldMap :: Int -> Int -> WorldData -> World
+worldMap w h d = (w, h, Set.fromList walls)
+  where
+    widx = zipWith (\ridx row -> zipWith (\cidx cell -> ((ridx, cidx), cell)) [0..] row) [0..] d
+    widx2 = concat widx
+    walls = fmap fst . filter (not . snd) $ widx2
+
+-- Subworld from above example
+subWorld :: Int -> Int -> World -> World
+subWorld w h (_, _, walls) = (w, h, Set.filter (\(r, c) -> r < h && c < w) walls)
+
+-- Initial states are not really given in the paper.
+-- Only the picture (8x8) shows a specific state, we take that.
+initialState :: Int -> Int -> State
+initialState w h | w <= 6 && h <= 4 = ((1, 0), E)
+                 | otherwise = ((6, 4), E)
+
+rotR :: Output -> Output
+rotR N = E
+rotR E = S
+rotR S = W
+rotR W = N
+rotR x = x
+
+rotL :: Output -> Output
+rotL E = N
+rotL S = E
+rotL W = S
+rotL N = W
+rotL x = x
+
+next :: Loc -> Output -> Loc
+next (r, c) N = (r-1, c)
+next (r, c) E = (r, c+1)
+next (r, c) S = (r+1, c)
+next (r, c) W = (r, c-1)
+
+isInBounds :: World -> Loc -> Bool
+isInBounds (w, h, _) (r, c) = 0 <= r && r < h && 0 <= c && c <= w
+
+isValid :: World -> Loc -> Bool
+isValid world@(w, h, walls) rc = isInBounds world rc && isValid1
+  where
+    isValid1 = not (rc `Set.member` walls)
+
+observation :: World -> State -> Output
+observation world (rc, dir) = if seesBoundary
+                              then dir
+                              else X
+  where
+    locs = takeWhile (isInBounds world) . iterate (`next` dir) $ rc
+    locs2 = takeWhile (isValid world) locs
+    seesBoundary = length locs == length locs2
+
+step :: World -> State -> State
+step world (rc, dir) = if isValid world nrc
+                       then (nrc, dir)
+                       else (rc, dir)
+  where
+    nrc = next rc dir
+
+delta :: World -> State -> Alphabet -> State
+delta world st F = step world st
+delta world (rc, d) R = (rc, rotR d)
+delta world (rc, d) L = (rc, rotL d)
+
+dotgraph :: Int -> Int -> String
+dotgraph w h = unlines ls
+  where
+    world = subWorld w h (worldMap 12 12 worldCxC)
+    allStates = takePutFront (initialState w h) . filter (isValid world . fst) $ [ ((r, c), d) | r <- [0..h-1], c <- [0..w-1], d <- [N, E, S, W]]
+    allSymbols = [F, R, L]
+
+    stateName ((r, c), d) = "r" ++ show r ++ "c" ++ show c ++ "d" ++ show d
+    stateDescr st = stateName st ++ " [label=\"" ++ show (observation world st) ++ "\"];"
+    transDescr st a = stateName st ++ " -> " ++ stateName (delta world st a) ++ " [label=\"" ++ show a ++ "\"];"
+
+    ls = [ "digraph crossword" ++ show w ++ "x" ++ show h ++ " {" ]
+      ++ [ emptyLine ]
+      ++ [ indent ++ stateDescr st | st <- allStates ]
+      ++ [ emptyLine ]
+      ++ [ indent ++ transDescr st a | st <- allStates, a <- allSymbols ]
+      ++ [ emptyLine ]
+      ++ [ "}" ]
+    
+    emptyLine = ""
+    indent = "  "
+    takePutFront x xs = x : delete x xs
+

moore/src/Gridworld.hs

@@ -0,0 +1,171 @@
+module Gridworld where
+
+{-
+
+From the Rivest and Schapire paper:
+
+" The n*n grid World. Consider a robot on an n X n square grid (with
+  “wraparound,” so that is is topologically a torus). The robot is on one of
+  the squares and is facing in one of the four possible directions. Each
+  square (except the one it currently occupies) is either red, green, or
+  blue. The robot can sense the color of the square it is facing. The
+  following actions are available to the robot: It can paint the square it
+  faces red, geen, or blue. The robot can turn left or right by 90 degrees,
+  or step forward one square in the direction it is facing. Stepping ahead
+  has the curious side effect of causeing the square it previously occupied
+  to be painted the color of the square it has just moved to, so moving
+  around causes the coloring to get scrabled up. "
+
+-}
+
+import Data.List (transpose, delete)
+import Control.Monad (replicateM)
+
+-- X is never used, only in intermediate steps
+data Output = Red | Green | Blue | X
+  deriving (Show, Eq)
+
+data Alphabet = F | R | L | P Output
+  deriving (Show, Eq)
+
+alphabet :: [Alphabet]
+alphabet = [F, R, L, P Red, P Green, P Blue]
+
+-- all very inefficient, but who cares
+-- The current position is left out, as the color will be swapped
+type Row = [Output]
+type World = [Row]
+
+r, g, b :: Output
+r = Red
+g = Green
+b = Blue
+
+-- From the paper, but with current position top-left,
+-- and facing the other direction. (It doesn't matter much.)
+-- Note that n=5 gives 282'429'536'481 states
+initialWorld5x5 :: World
+initialWorld5x5 = [    [ b, b, g, g ]
+                  , [ g, r, g, r, b ]
+                  , [ r, g, b, r, g ]
+                  , [ r, b, b, g, b ]
+                  , [ g, r, r, b, r ]
+                  ]
+
+-- Subworld from above example
+subWorld :: Int -> Int -> World
+subWorld w h = take (w-1) crow : fmap (take w) rest
+  where
+    sub1 = take h initialWorld5x5
+    (crow:rest) = sub1
+
+initialWorld2x2 :: World
+initialWorld2x2 = [    [ b ]
+                  , [ g, r ]
+                  ]
+
+initialWorld2x3 :: World
+initialWorld2x3 = [    [ b, b ]
+                  , [ g, r, g ]
+                  ]                
+
+stepForward :: World -> World
+stepForward world = world2
+  where
+    (crow:frow:rest) = world
+    (facing:nrow) = frow
+    urow = facing:crow
+    world2 = nrow:rest ++ [urow]
+
+-- Reverse except the first.
+reverse1 :: [a] -> [a]
+reverse1 [] = []
+reverse1 (x:xs) = x:reverse xs
+
+-- Rotation is a transpose and reversing the columns.
+rotateRight :: World -> World
+rotateRight world = world2
+  where
+    (w:orld) = world
+    worldX = (X:w):orld
+    worldXT = transpose worldX
+    worldXTR = fmap reverse1 worldXT
+    (_:w2):orld2 = worldXTR
+    world2 = w2:orld2
+
+-- The other rotation is 3x the right one.
+rotateLeft :: World -> World
+rotateLeft = rotateRight . rotateRight . rotateRight
+
+paint :: World -> Output -> World
+paint world n = world2
+  where
+    (crow:frow:rest) = world
+    (_:nrow) = frow
+    lrow = n:nrow
+    world2 = crow:lrow:rest
+
+delta :: World -> Alphabet -> World
+delta world F = stepForward world
+delta world R = rotateRight world
+delta world L = rotateLeft world
+delta world (P c) = paint world c
+
+observation :: World -> Output
+observation world = facing
+  where
+    (_:frow:_) = world
+    (facing:_) = frow
+
+allRows :: Int -> [Row]
+allRows 0 = []
+allRows 1 = [[Red], [Green], [Blue]]
+allRows n = do
+  fa <- [Red, Green, Blue]
+  ro <- allRows (n-1)
+  return (fa:ro)
+
+allWorlds :: Int -> Int -> [World]
+allWorlds w h = do
+  crow <- allRows (w-1)
+  rest <- replicateM (h-1) (allRows w)
+  return (crow:rest)
+
+stateName :: World -> String
+stateName w = "s" ++ fmap cname (concat w)
+  where
+    cname Red = 'R'
+    cname Green = 'G'
+    cname Blue = 'B'
+    cname X = 'X'
+
+stateDescr :: World -> String
+stateDescr bs = stateName bs ++ " [label=\"" ++ clongname (observation bs) ++ "\"];"
+  where
+    clongname Red = "Red"
+    clongname Green = "Green"
+    clongname Blue = "Blue"
+    clongname X = "There is a bug in the generation"
+
+transDescr :: World -> Alphabet -> String
+transDescr bs a = stateName bs ++ " -> " ++ stateName (delta bs a) ++ " [label=\"" ++ show2 a ++ "\"];"
+  where
+    show2 (P c) = 'P':show c
+    show2 x = show x
+
+dotgraph :: Int -> Int -> String
+dotgraph w h = unlines ls
+  where
+    ls = [ "digraph grid" ++ show w ++ "x" ++ show h ++ " {" ]
+      ++ [ emptyLine ]
+      ++ [ indent ++ stateDescr bs | bs <- all ]
+      ++ [ emptyLine ]
+      ++ [ indent ++ transDescr bs a | bs <- all, a <- alphabet ]
+      ++ [ emptyLine ]
+      ++ [ "}" ]
+    all = if w <= 5 && h <= 5
+            then takePutFront (subWorld w h) (allWorlds w h)
+            else allWorlds w h
+    emptyLine = ""
+    indent = "  "
+    takePutFront x xs = x : delete x xs

moore/src/Lib.hs

@@ -0,0 +1,6 @@
+module Lib
+    ( someFunc
+    ) where
+
+someFunc :: IO ()
+someFunc = putStrLn "someFunc"

moore/src/Registerworld.hs

@@ -0,0 +1,79 @@
+module Registerworld where
+
+import Prelude hiding (flip)
+
+{-
+
+From the Rivest and Schapire paper:
+
+" In this environment, the robot is able to read the leftmost bit of an n-bit
+ register, such as the 10-bit register depicted in Figure 1. Its actions allow
+ it to rotate the register left or right (with wraparound) or to flip the bit
+ it sees. Clearly, this automaton consists of 2“ global states, but its
+ diversity is only 2n since there is one test for each bit, and one for the
+ complement note that the register world is a permutation automaton. "
+
+-}
+
+-- Not very efficient, but who cares
+type Bitstring = String
+
+data Alphabet = L | R | F
+  deriving Show
+
+rotateL :: Bitstring -> Bitstring
+rotateL [] = []
+rotateL (x:xs) = xs ++ [x]
+
+rotateR :: Bitstring -> Bitstring
+rotateR = reverse . rotateL . reverse
+
+flip :: Bitstring -> Bitstring
+flip [] = []
+flip (x:xs) = flipBit x : xs
+  where
+    flipBit '0' = '1'
+    flipBit '1' = '0'
+    flipBit c = c
+
+delta :: Bitstring -> Alphabet -> Bitstring
+delta bs L = rotateL bs
+delta bs R = rotateR bs
+delta bs F = flip bs
+
+observation :: Bitstring -> String
+observation = pure . head
+
+allBitstrings :: Int -> [Bitstring]
+allBitstrings 0 = []
+allBitstrings 1 = ["0", "1"]
+allBitstrings n = do
+  b <- ['0', '1']
+  bs <- allBitstrings (n-1)
+  return (b:bs)
+
+allSymbols :: [Alphabet]
+allSymbols = [L, R, F]
+
+stateName :: Bitstring -> String
+stateName bs = "state" ++ bs
+
+stateDescr :: Bitstring -> String
+stateDescr bs = stateName bs ++ " [label=\"" ++ observation bs ++ "\"];"
+
+transDescr :: Bitstring -> Alphabet -> String
+transDescr bs a = stateName bs ++ " -> " ++ stateName (delta bs a) ++ " [label=\"" ++ show a ++ "\"];"
+
+dotgraph :: Int -> String
+dotgraph n = unlines ls
+  where
+    ls = [ "digraph register" ++ show n ++ " {" ]
+      ++ [ emptyLine ]
+      ++ [ indent ++ stateDescr bs | bs <- allbs ]
+      ++ [ emptyLine ]
+      ++ [ indent ++ transDescr bs a | bs <- allbs, a <- allSymbols ]
+      ++ [ emptyLine ]
+      ++ [ "}" ]
+    allbs = allBitstrings n
+    emptyLine = ""
+    indent = "  "

moore/stack.yaml

@@ -0,0 +1,4 @@
+resolver: lts-16.8
+
+packages:
+- .