Probabilistic automata

probabilistic/README.md

@@ -0,0 +1,10 @@
+Probabilistic models
+====================
+
+With the weighted automata semantics (i.e. weighted outputs and no state
+labels). I have implemented:
+
+* Gridworld 1 and 2 from Tappler et al 2019.
+  Note: This is note the same semantics, so I had to convert it a little
+  bit. It is comparable (but smaller).
+

probabilistic/Setup.hs

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

probabilistic/app/Main.hs

@@ -0,0 +1,15 @@
+module Main where
+
+import PA
+import Grid
+import Output
+
+main :: IO ()
+main = do
+    writeFile "example.dot" (dotShow example)
+    writeFile "example.pa" (denseShow example)
+    writeFile "grid1.dot" (dotShow firstPA)
+    writeFile "grid1.pa" (denseShow firstPA)
+    writeFile "grid2.dot" (dotShow secondPA)
+    writeFile "grid2.pa" (denseShow secondPA)
+

probabilistic/probabilistic.cabal

@@ -0,0 +1,27 @@
+cabal-version:       2.2
+name:                probabilistic
+version:             0.1.0.0
+author:              Joshua Moerman
+maintainer:          joshua@cs.rwth-aachen.de
+build-type:          Simple
+
+common stuff
+  default-language: Haskell2010
+  build-depends:
+    base >=4.14 && <4.15,
+    containers
+
+library pag
+  import: stuff
+  hs-source-dirs: src
+  exposed-modules:
+    Grid,
+    PA,
+    Prob,
+    Output
+
+executable probabilistic
+  import: stuff
+  hs-source-dirs: app
+  main-is: Main.hs
+  build-depends: pag

probabilistic/src/Grid.hs

@@ -0,0 +1,100 @@
+{-# language TypeSynonymInstances  #-}
+{-# language FlexibleInstances  #-}
+
+module Grid where
+
+import PA
+import Prob
+import Output
+
+type Alph = Char
+
+alph :: [Alph]
+alph = "NESW"
+
+-- word data with sizes
+type World = ([[Char]], Int, Int)
+
+first :: [[Char]]
+first =
+  [ "CCCMW"
+  , "WWWCM"
+  , "SMGCG"
+  , "MGCMW"
+  , "GSMGW"
+  ]
+
+firstW :: World
+firstW = (first, length (head first), length first)
+
+second :: [[Char]]
+second =
+  [ "CCMCCGMS"
+  , "CGWWGMCG"
+  , "CMSGMCGW"
+  , "SCCCCGSC"
+  , "MWCCGSMC"
+  , "GSMGWWGM"
+  ]
+
+secondW :: World
+secondW = (second, length (head second), length second)
+
+-- either a valid position or a wall
+type State = Either () (Int, Int)
+
+instance StateShow State where
+  sshow (Left ()) = "W"
+  sshow (Right (c, r)) = "p" <> show c <> "x" <> show r
+
+delta :: World -> State -> Alph -> V State
+delta (grid, w, h) (Left ()) _ = []
+delta (grid, w, h) (Right (c, r)) i =
+  let currCell = grid !! r !! c
+      filterValid (c', r') =
+        if 0 <= c' && c' < w && 0 <= r' && r' < h
+        then case grid !! r' !! c' of
+             'W' -> Left ()
+             cel -> Right (c', r')
+        else Left ()
+      probs =
+        case currCell of
+          'C' -> fmap (0.25 *) [0, 1, 0]       -- concrete
+          'M' -> fmap (0.25 *) [0.1, 0.8, 0.1] -- mud
+          'G' -> fmap (0.25 *) [0.2, 0.6, 0.2] -- grass
+          'S' -> fmap (0.25 *) [0.3, 0.4, 0.3] -- sand
+      nextCoords =
+        case i of
+          'N' -> [(c-1, r-1), (c, r-1), (c+1, r-1)]
+          'E' -> [(c+1, r-1), (c+1, r), (c+1, r+1)]
+          'S' -> [(c-1, r+1), (c, r+1), (c+1, r+1)]
+          'W' -> [(c-1, r-1), (c-1, r), (c-1, r+1)]
+  in vector (zip (fmap filterValid nextCoords) probs)
+
+ini :: V State
+ini = dirac (Right (0, 0))
+
+acc :: State -> Prob
+acc (Left _) = 1
+acc (Right _) = 0
+
+ss :: World -> [State]
+ss (grid, w, h) = Left () : fmap Right goodCells
+  where
+    allCells = (,) <$> [0..w-1] <*> [0..h-1]
+    goodCells = filter (\(c, r) -> grid !! r !! c /= 'W') allCells
+
+toPA :: World -> PA State Alph
+toPA world = PA
+  { states = ss world
+  , alphabet = alph
+  , initialState = ini
+  , acceptance = acc
+  , transitions = delta world
+  }
+
+firstPA :: PA State Alph
+firstPA = toPA firstW
+
+secondPA :: PA State Alph
+secondPA = toPA secondW

probabilistic/src/Output.hs

@@ -0,0 +1,60 @@
+{-# language PartialTypeSignatures #-}
+{-# language TupleSections #-}
+{-# language DerivingVia #-}
+{-# language StandaloneDeriving #-}
+{-# language TypeSynonymInstances #-}
+{-# language FlexibleInstances #-}
+
+module Output where
+
+import PA
+import Prob (Prob)
+import Data.List (intercalate)
+import qualified Data.Map as Map
+import Text.Printf
+
+probShow :: Prob -> String
+probShow p = printf "%f" (fromRational p :: Double)
+
+-- Printing the PA
+class StateShow x where
+  sshow :: x -> String
+class InputShow i where
+  ishow :: i -> String
+
+instance StateShow String where sshow str = str
+instance InputShow String where ishow str = str
+instance StateShow Char where sshow c = [c]
+instance InputShow Char where ishow c = [c]
+
+newtype DefaultShow x = DS { unDS :: x }
+instance (Show x) => StateShow (DefaultShow x) where sshow (DS x) = "s" <> show x
+instance (Show i) => InputShow (DefaultShow i) where ishow (DS i) = "i" <> show i
+
+deriving via DefaultShow Int instance StateShow Int
+deriving via DefaultShow Int instance InputShow Int
+
+dotShow :: (StateShow s, InputShow i) => PA s i -> String
+dotShow pa =
+  "digraph pa {\n"
+  <> concatMap (\s -> "  " <> sshow s <> " [label=\"" <> probShow (acceptance pa s) <> "\"]\n") (states pa)
+  <> concatMap (\(s, p) -> "  _init -> " <> sshow s <> " [probability=\"" <> probShow p <> "\"]\n") (initialState pa)
+  <> concatMap (\(s, i, (t, p)) -> "  " <> sshow s <> " -> " <> sshow t <> " [label=\"" <> ishow i <> "\" probability=\"" <> probShow p <> "\"]\n") allTrans
+  <> "}\n"
+  where
+    allTrans = concatMap (\(s, i) -> fmap (s,i,) (transitions pa s i)) $ (,) <$> states pa <*> alphabet pa
+
+
+denseShow :: (StateShow s, InputShow i, Ord s) => PA s i -> String
+denseShow pa =
+  "states = [" <> intercalate ", " (fmap sshow (states pa)) <> "]\n"
+  <> "alphabet = [" <> intercalate ", " (fmap ishow (alphabet pa)) <> "]\n"
+  <> "initial = [" <> intercalate ", " (fmap (\s -> probShow (Map.findWithDefault 0 s iMap)) (states pa)) <> "]\n"
+  <> "final = " <> showV (probShow . acceptance pa) (states pa) <> "\n"
+  <> intercalate "\n" (fmap (\a -> "trans_" <> ishow a <> " = " <> showM (matrixFor a)) (alphabet pa))
+  <> "\n"
+  where
+    iMap = Map.fromList (initialState pa)
+    matrixFor i = [[ Map.findWithDefault 0 c row | c <- states pa] | r <- states pa, let row = Map.fromList (transitions pa r i)]
+    showM (firstR:restR) = "[" <> showV probShow firstR <> ",\n    " <> intercalate ",\n    " (fmap (showV probShow) restR) <> "]"
+    showV f l = "[" <> intercalate ", " (fmap f l) <> "]"

probabilistic/src/PA.hs

@@ -0,0 +1,35 @@
+{-# language PartialTypeSignatures #-}
+{-# language TupleSections #-}
+{-# language DerivingVia #-}
+{-# language StandaloneDeriving #-}
+{-# language TypeSynonymInstances #-}
+{-# language FlexibleInstances #-}
+
+module PA where
+
+import Prob
+
+-- Probabilistic Automata
+data PA s i = PA
+  { states :: [s]
+  , alphabet :: [i]
+  , initialState :: V s
+  , acceptance :: s -> Prob
+  , transitions :: s -> i -> V s }
+
+example :: PA Int Char
+example = PA
+  { states = [0, 1, 2]
+  , alphabet = ['a']
+  , initialState = vector [(0, 1)]
+  , acceptance = \n ->
+      case n of
+        0 -> 0
+        1 -> 0.1
+        n -> 1
+  , transitions = \n c ->
+      case n of
+        0 -> vector [(1, 0.5), (0, 0.5)]
+        1 -> vector [(2, 0.9)]
+        n -> []
+  }

probabilistic/src/Prob.hs

@@ -0,0 +1,22 @@
+{-# language TupleSections #-}
+
+module Prob where
+
+import qualified Data.Map as Map
+
+-- Probability Distributions
+type Prob = Rational
+type V s = [(s, Prob)]
+
+-- sums up duplicates
+vector :: (Ord s) => [(s, Prob)] -> V s
+vector = Map.toList . Map.filter (> 0) . Map.fromListWith (+)
+
+-- point distribution
+dirac :: a -> V a
+dirac x = [(x, 1)]
+
+-- uniform distribution
+unif :: (Ord a) => [a] -> V a
+unif l = vector (fmap (,p) l)
+  where p = 1 / fromIntegral (length l)