Commit d12e3c38 authored by Cezar Ionescu's avatar Cezar Ionescu
Browse files

Examples!

parent 9923b65d
> {-# LANGUAGE MultiParamTypeClasses #-}
> module SequentialDecisionProblems.CoreTheory where
> import Data.List
---------Begin of "interface"------------------------------------
> module SequentialDecisionProblems.CoreTheory where
> data State
......@@ -28,14 +29,20 @@
> val :: State -> PolicySeq -> Val
> admissible :: State -> Ctrl -> Bool
> optExt :: PolicySeq -> Policy
-- val (optExt ps s : ps) s >= val (p : ps) s for "all" s, p, ps
> backwardsInduction :: Nat -> PolicySeq
> type StateCtrlSeq = [(State, Maybe Ctrl)]
> trj :: PolicySeq -> State -> M StateCtrlSeq
--------Important, but not used----------------------------------
> melem :: a -> M a -> Bool
> mnull :: M a -> Bool
> mall :: (a -> Bool) -> M a -> Bool
......@@ -60,12 +67,22 @@
> val _ [] = zero
> val s (p : ps) = cval s ps (p s)
> optExt ps s = snd (head (sortBy o [(cval s ps c, c) | c <- [minBound .. maxBound], admissible s c]))
> where
> o (v1, c1) (v2, c2) = if v1 > v2
> then LT
> else if v1 < v2 then GT
> else EQ
> backwardsInduction n = if n == 0
> then []
> else optExt ps : ps
> where ps = backwardsInduction (n - 1)
> trj [] s = return [(s, Nothing)]
> trj (p : ps) s = fmap ((s, Just (p s)) : ) (nexts s (p s) >>= trj ps)
-----------User-defined implementations-------------------------
> instance Eq Val where
......@@ -89,12 +106,19 @@
> return = undefined
> (>>=) = undefined
> instance Bounded Ctrl where
> minBound = undefined
> maxBound = undefined
> instance Enum Ctrl where
> fromEnum = undefined
> toEnum = undefined
> nexts = undefined
> reward = undefined
> meas = undefined
> admissible = undefined
> optExt ps s = undefined
> optExt ps s = undefined
---------User-defined if needed----------------------------------
......
> {-# LANGUAGE GeneralizedNewtypeDeriving #-}
> module SequentialDecisionProblems.Example1 where
> import Data.List
> import Control.Monad.Identity
> maxColumn :: Nat
> maxColumn = 10
> nColumns :: Nat
> nColumns = maxColumn + 1
---------Begin of "interface"------------------------------------
> newtype State = State Nat -- State t = LTB nColumns
> deriving (Show, Eq, Ord, Enum)
> instance Bounded State where
> maxBound = State maxColumn
> minBound = State 0
> data Ctrl = L | A | R
> deriving (Show, Eq, Enum, Bounded)
> type Nat = Int
> type Val = Nat
> zero :: Val
> type M a = Identity a
> nexts :: State -> Ctrl -> M State
> reward :: State -> Ctrl -> State -> Val
> reward (State s) c (State s')
> | s' == 0 = 1
> | s' == maxColumn = 2
> | s' > 0 && s' < maxColumn = 0
> meas :: M Val -> Val
> meas (Identity n) = n
> type Policy = State -> Ctrl
> -- Policy t (S m) = (x : State t) -> Reachable x -> Viable (S m) x -> GoodCtrl t x m
> type PolicySeq = [Policy]
> cval :: State -> PolicySeq -> Ctrl -> Val
> val :: State -> PolicySeq -> Val
> optExt :: PolicySeq -> Policy
-- val (optExt ps s : ps) s >= val (p : ps) s for "all" s, p, ps
> backwardsInduction :: Nat -> PolicySeq
--------Important, but not used----------------------------------
> melem :: a -> M a -> Bool
> mnull :: M a -> Bool
> mall :: (a -> Bool) -> M a -> Bool
> mtag :: M a -> M (a, Bool)
> viable :: State -> Nat -> Bool
> good :: State -> Ctrl -> Nat -> Bool
> reachable :: State -> Bool
-------Default implementation------------------------------------
> good s c n = not (mnull ms) && mall (\ a -> viable a n) ms
> where
> ms = nexts s c
> cval s ps c = meas mr
> where
> ms = nexts s c
> mr = fmap (\ s' -> reward s c s' + val s' ps) ms
> val _ [] = zero
> val s (p : ps) = cval s ps (p s)
> backwardsInduction n = if n == 0
> then []
> else optExt ps : ps
> where ps = backwardsInduction (n - 1)
> trj [] s = return [(s, Nothing)]
> trj (p : ps) s = fmap ((s, Just (p s)) : ) (nexts s (p s) >>= trj ps)
-----------User-defined implementations-------------------------
> zero = 0
> nexts (State n) A = Identity (State n)
> nexts (State n) L = if n == 0
> then Identity (State maxColumn)
> else Identity (State (n - 1))
> nexts (State n) R = if n == maxColumn
> then Identity (State 0)
> else Identity (State (n + 1))
> optExt ps s = snd (head (sortBy o [(cval s ps c, c) | c <- [minBound .. maxBound]]))
> where
> o (v1, c1) (v2, c2) = if v1 > v2
> then LT
> else if v1 < v2 then GT
> else EQ
---------User-defined if needed----------------------------------
> melem = undefined
> mnull = undefined
> mall = undefined
> mtag = undefined
> viable = undefined
> reachable = undefined
> {-
* The computation:
> computation : { [STDIO] } Eff ()
> computation =
> do putStr ("enter number of steps:\n")
> nSteps <- getNat
> putStr ("enter initial column:\n")
> x0 <- getLTB nColumns
> case (dViable {t = Z} nSteps x0) of
> (Yes v0) => do putStrLn ("computing optimal policies ...")
> ps <- pure (backwardsInduction Z nSteps)
> putStrLn ("computing optimal controls ...")
> mxys <- pure (possibleStateCtrlSeqs x0 () v0 ps)
> putStrLn (show mxys)
> putStrLn ("done!")
> (No _) => putStrLn ("initial column non viable for " ++ cast {from = Int} (cast nSteps) ++ " steps")
> main : IO ()
> main = run computation
<
> ---}
> {-# LANGUAGE GeneralizedNewtypeDeriving #-}
> module SequentialDecisionProblems.Example2 where
> import Data.List
> import Control.Monad.Identity
---------Begin of "interface"------------------------------------
> maxCol :: Nat
> maxCol = 10
> newtype Col = Col Nat
> deriving (Show, Eq, Ord, Enum)
> instance Bounded Col where
> minBound = Col 0
> maxBound = Col maxCol
> type Step = Nat
> type State = (Col, Step)
> data Ctrl = L | A | R
> deriving (Show, Eq, Ord, Enum, Bounded)
> type Nat = Int
> type Val = Maybe Int
> zero :: Val
> type M a = Identity a
> meas :: M Val -> Val
> nexts :: State -> Ctrl -> M State
> reward :: State -> Ctrl -> State -> Val
> type Policy = State -> Ctrl
> -- Policy t (S m) = (x : State t) -> Reachable x -> Viable (S m) x -> GoodCtrl t x m
> type PolicySeq = [Policy]
> cval :: State -> PolicySeq -> Ctrl -> Val
> val :: State -> PolicySeq -> Val
> optExt :: PolicySeq -> Policy
-- val (optExt ps s : ps) s >= val (p : ps) s for "all" s, p, ps
> backwardsInduction :: Nat -> PolicySeq
> type StateCtrlSeq = [(State, Maybe Ctrl)]
> trj :: PolicySeq -> State -> M StateCtrlSeq
--------Important, but not used----------------------------------
> melem :: a -> M a -> Bool
> mnull :: M a -> Bool
> mall :: (a -> Bool) -> M a -> Bool
> mtag :: M a -> M (a, Bool)
> viable :: State -> Nat -> Bool
> good :: State -> Ctrl -> Nat -> Bool
> reachable :: State -> Bool
-------Default implementation------------------------------------
> good s c n = not (mnull ms) && mall (\ a -> viable a n) ms
> where
> ms = nexts s c
> cval s ps c = meas mr
> where
> ms = nexts s c
> mr = fmap (\ s' -> reward s c s' + val s' ps) ms
> val _ [] = zero
> val s (p : ps) = cval s ps (p s)
> optExt ps s = snd (head (sortBy o [(cval s ps c, c) | c <- [minBound .. maxBound], admissible s c]))
> where
> o (v1, c1) (v2, c2) = if v1 > v2
> then LT
> else if v1 < v2 then GT
> else EQ
> backwardsInduction n = if n == 0
> then []
> else optExt ps : ps
> where ps = backwardsInduction (n - 1)
> trj [] s = return [(s, Nothing)]
> trj (p : ps) s = fmap ((s, Just (p s)) : ) (nexts s (p s) >>= trj ps)
-----------User-defined implementations-------------------------
> instance Num a => Num (Maybe a) where
> Nothing + _ = Nothing
> _ + Nothing = Nothing
> Just a + Just b = Just (a + b)
> Nothing * _ = Nothing
> _ * Nothing = Nothing
> Just a * Just b = Just (a * b)
> abs Nothing = Nothing
> abs (Just a) = Just (abs a)
> signum Nothing = Nothing
> signum (Just a) = Just (signum a)
> fromInteger n = Just (fromInteger n)
>
> zero = Just 0
> reward s c (Col n, t) = if t == 3 && n /= maxCol
> then Nothing
> else r n
> where
> r n
> | n == 0 = 1
> | n == maxCol = 2
> | n > 0 && n < maxCol = 0
> meas (Identity v) = v
> nexts (Col n, t) A = Identity (Col n, t + 1)
> nexts (Col n, t) L = if n > 0
> then Identity (Col (n-1), t+1)
> else undefined
> nexts (Col n, t) R = if n < maxCol
> then Identity (Col (n + 1), t+1)
> else undefined
> admissible (n, t) c
> | n == minBound = c /= L
> | n == maxBound = c /= R
> | n /= minBound && n /= maxBound = True
> optExt ps s = undefined
---------User-defined if needed----------------------------------
> melem = undefined
> mnull = undefined
> mall = undefined
> mtag = undefined
> viable = undefined
> reachable = undefined
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment