From a86ec8b064007727f2e4ed468020be8786771b3b Mon Sep 17 00:00:00 2001 From: Joshua Moerman Date: Mon, 1 Feb 2021 11:44:11 +0100 Subject: [PATCH] Probabilistic automata --- probabilistic/README.md | 10 +++ probabilistic/Setup.hs | 2 + probabilistic/app/Main.hs | 15 +++++ probabilistic/examplePA.zip | Bin 0 -> 4953 bytes probabilistic/probabilistic.cabal | 27 ++++++++ probabilistic/src/Grid.hs | 100 ++++++++++++++++++++++++++++++ probabilistic/src/Output.hs | 60 ++++++++++++++++++ probabilistic/src/PA.hs | 35 +++++++++++ probabilistic/src/Prob.hs | 22 +++++++ 9 files changed, 271 insertions(+) create mode 100644 probabilistic/README.md create mode 100644 probabilistic/Setup.hs create mode 100644 probabilistic/app/Main.hs create mode 100644 probabilistic/examplePA.zip create mode 100644 probabilistic/probabilistic.cabal create mode 100644 probabilistic/src/Grid.hs create mode 100644 probabilistic/src/Output.hs create mode 100644 probabilistic/src/PA.hs create mode 100644 probabilistic/src/Prob.hs 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 0000000000000000000000000000000000000000..26283295a9ea77d08b59720c9a0f4f4879473396 GIT binary patch literal 4953 zcmZ`-2T)U6*9~1jsvy-+L_k0~f=H;Lx6nbVbW}Q_gB0n#*C0&-N)d@PX;KUwsY(+F zJ(AFZfFOMMee>qM=Rf~Fv**sabJyK#&fK&2Sqq{`Ku8Aw0ImU?AkzAdv~vlLS2OHY zkY9y^|6^B=XAXk)?mn6WT0$BE{SaO?!^(|yeF*P;NbIP(mc~fEk?3bJNIX#j6K5Qg zVqfC2ZL~0SKQAEf4q2K?ZGxsJEylUs@)>q4)qY5~o4N%SVCJ(lcbHEt#OM zp178xp_w}P$Vw0Z`4=6f;v8?=D;nijLG}+i9*_A2)dke=8NW4(6}OC(MF2a}opG!qp56%$qffb@!qlb4IV$nRyz%GFMo zmZw%eCOBm4o_~nTX`X1u(7m8%MBC`NMyF$V z2{<-%?D9ZYs7Z1XCmhmNBxGIZuDdT-DErI&QMdO=Cv*O^eXXPSd&W28Q%MzW;?T0H z0f4K@P;C$Lwi{8{0g)W^~M9hu)&fV1dr;WeP0Q- z+E@0qZ>k3afr=mDt+W~R0$T!{(nZn%eCy1Gt^%NI%!(cj&F%>$Yn+c_PN7YS)r86v zaACTuaweL^s^UM)c(PlVG!__8*J>~exKCjERlZyV8wtR2>9Nt+i-2nJMvE$M`zJ+8 z84FTVE(NADH})np&PuDXr0eXSI_tdq;uWJoU0p6W7#)Rspbo-LP={-(VwBKtgv2@@ z8C*h*6wsHW8-W@uuoGVO;VZ*$kpnv4G}FtQhbP{NCVfssm~+6%(-Cx`Ha?4s{DqTdD?9BUK>>_(V{y5JFyvJ}@vD3Wp%oy0)5F#C-uN^B!LbovV83o3 z^K`1mv0cpTn%-^N*0`p-P0#z@S4&MP+Qm~AOwj4}#4=dU?un&LXJGYfgJ(v- zO=^E9=;c_+4zn5AW*)sCY`JA`jIPhtd0WzF#sBuw9;bJol#F^8Igf2>+neC{SBsVw zD^;fv!4Y4|e?2>I#&2s$^yyy@Hr_bEZnEdt3XKiPl%=o0>cVX3o%d4yx@N zAWRpIfIyB6*|K265B{1}~gzKX@{lRj{cb)VWid zIUBBP2Romi>$rE1=k*Xr;pE`5;j2?&tmm3p9Oom82}3``BX5~J3xO`qvA?TfE$`E; z%2`qIdBow7=%cTd9c@pcn8#9dpG@M8X`87<+I)CC`991Jfb==wzH8RmWq3bgVbylB zC|iP(>pPA>{d|$8ed!PmCq-Vu)^@tVIu-U+IkwGD(5a>z#|`OmiCP1w@XVuM;X*^d z+>qWBkoHF9Y4I%3*MrDCC9Ga*XPHcb(VW%SBWm(Y$&9aIE1e^FeP@R|Gzj7LODX;7 z(gsUaEP=-$x9y$mH;1;fY~~N;MAg@_d*C7yE+V@Uyp%7{wZDYDi2mIOGGB{^(GUXw z>vDgWU(x@T-+b)^ZV9@m-{sdTa2KK;Qsc8Zlayc;t0ozLUwrO*1Elw|w!1)w?|3T1 zU>>!yw#E(JtuYJ@Jv};{oOf?(g3m9p$t}30G_hH|EP5XB>nBG@J}~tBa(o`QiM#N5 zQp9~KJ_K(FZtaJ^@y{=h;R11ObEs3PCugrao1q=63f33ivASlLjd&r zR5iEfV%UD12E4ibIIFD23t^PpI5=+nV2)dLe$Ban)itBcm8Y!g1Uu0q2-@*NSSB~V z84nFS{k1-XdE<^1+MeH(D|%UEZDrkYKHb@MDRQ)UfnD*HhwBD_-o-Fr=S99bM()P= zLl4xRy%zIMgn!syV-iBoiWLbmj&X21%Pb{1jrr@n1g)M%><1upE7~Ke@DhX3TQ7Vd z&tJrX`B@eE#=78Q{33IAi5)o3wV1v*GSzBRvHghs8h#6wN{L3?=elRi&FDV#?&IWK zWo31j>UVG?y~QvTk-HrW^vx{R&2q7>Q>h-y64|cy6_|)Z`8ZMiVk#fRSq)XAGQT~Y zU1Rb?Pfo3p?oX|rrc2j8R8PneK;>H6nO44ye@iXcX05+@hu$AwCf5ZXkG8y9!BtSr z&3Qn28tfRA{w!^SB9#F1>Reh6?KB0hzr>SFmfi*QP2SvEM0h(u;ZMn=VmgpDiB{#a z0g>}Wf@Vau_uZq$zWCQ=7@~kF61ZV9;$Tz7vZVXbz)pPYXPe~o(r+Pmu{$g0t1@+j z4m54wK5?*2JZ0k*rm0DRU~1Z2eMn*E0p4pEXu(gFs5W@f!~fDdHJFRU~a~h>3Ljs;9urZCWno zbP-Qw5FlF`|WOq1+r;Q^(A1B1r2LQ*84 zWsG^sL&;F)<62GXa_XZmQuiN zo>7(@sT&s|#6Wur1Dz|quzcUP8S))bx7?63lyhdLo6ytB5Ue0`bP}iyyM5c^_08@? z=(5ReyITX({iY!pF#imk$G#rC%TZTvbjdQSUx}NsqTRK@&^+T`Yj;(YaBe&MM4G*ahr=%k1Og>)YxU0pl)wr5L^_*22OB_J0;&Q(KKi2)jx{ z^K%!*&yQE*I`zMhc*?qmhi@?19bgyG+PV}!xP z2cHN4D9Zc$v?3~aby_JLaYG4HhwWzlq?7?XN|RqkAgzM7OJZI>s@FG3Ff^LZR$_bp zSpN?9(U`wXBa#vnOtM2Ln}U4)B9!$QnUm5t);GE8wcqj60*}Rp+=4)|3)@SK7KgyY zr75OdiV;y0H?7=Pj&9bvmiSP-ddh35w9TyX1=1QmL9q}(0KE@!B7jQsVu}%w6O{wk2}pyF zD;N)%9qX~Wy3j)G=fe8eBs_g`F-=x)?@M;6@13|`{@DM1QGK#jZOvJf(#+>n|km|CqwW4MizeoeSQOCS{QJ)dH}45hrcb-r$P`&)NxUeZhc4`p{! z6hu*_ zFI_*V1QR5RS6seMsIMf&>GLkr{aP_@w!>b*k7Q z%?C4?+Neq^i{f86z?}!QI6#yXv4GMUdTZTA@I^=#j$UPa-0*tbxQDCNyNLYo8)_6K z%3f%XvZc&g)XBy zdy6BDPbbYYJ;T5+uX*w}m^#Q*k@yups#CP)T?}Zj|1&&K-K_*AjM$6Ii;{B3w_CIK za07f}3-odt`h#S9!L)CEL2Yauj-kz>pD8g_hRakgEi{hK5xI=WaRN1u!f}8>6R<)W zf5S4i>=cC%>@23QI#aU+$txnC{!j+vZfcjQ&N_1l_Od6jhrJu`w%C$aRFdpA^noB5 zz);{@bH=m>ftjzutXJ)C66OZoQPtNFM&Q?#MhdiFyJZY29((s;1MfiOUN0;?JU!

cphX+9$;u&daDAMG!*jcb zu9M~+=Rhq9^=khdh`y5ls5;l-Jcn;i9<7AK|bL1z`SG=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)