diff --git a/probabilistic/README.md b/probabilistic/README.md new file mode 100644 index 0000000..81b3bae --- /dev/null +++ b/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). + diff --git a/probabilistic/Setup.hs b/probabilistic/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/probabilistic/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/probabilistic/app/Main.hs b/probabilistic/app/Main.hs new file mode 100644 index 0000000..f94c0fc --- /dev/null +++ b/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) + diff --git a/probabilistic/examplePA.zip b/probabilistic/examplePA.zip new file mode 100644 index 0000000..2628329 Binary files /dev/null and b/probabilistic/examplePA.zip differ diff --git a/probabilistic/probabilistic.cabal b/probabilistic/probabilistic.cabal new file mode 100644 index 0000000..b06dd82 --- /dev/null +++ b/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 diff --git a/probabilistic/src/Grid.hs b/probabilistic/src/Grid.hs new file mode 100644 index 0000000..9271257 --- /dev/null +++ b/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 diff --git a/probabilistic/src/Output.hs b/probabilistic/src/Output.hs new file mode 100644 index 0000000..555c4e3 --- /dev/null +++ b/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) <> "]" diff --git a/probabilistic/src/PA.hs b/probabilistic/src/PA.hs new file mode 100644 index 0000000..8529fa8 --- /dev/null +++ b/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 -> [] + } diff --git a/probabilistic/src/Prob.hs b/probabilistic/src/Prob.hs new file mode 100644 index 0000000..baf74e1 --- /dev/null +++ b/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)