All geek questions in one place

How can I get a limited state machine in Haskell / Idris?

EDIT: Users of @apocalisp and @BenjaminHodgson left amazing answers below, skip reading most of the questions and go to their answers.

TL; DR question: how can I go from the first image, where the FSM announces a combinatorial explosion, to the second image, where you just need to visit all of them before moving on.

I would like to build a final state machine (in Haskell really, but I try to see Idris first if he can drive my Haskell), where there are some intermediate states that you need to visit before you can reach the final state, It would be great if so that I could arbitrarily restrain FSM with predicates in some state.

The following figure has a state Initial, 3 intermediate states A, B, Cand a Final. If I'm not mistaken, in a “normal” FSM you will always need temporary states n!to represent each combination of possible paths.

Combinatorial explosion

This is undesirable.

Instead, using type types and possibly dependent types, I think it should be possible to have some kind of state that wraps around, and only when it passes certain predicates will you be allowed to go to the final state. (Does that make it Push Down Automata instead of FSM?)

Limited state machine

My code is still (idris), which, by analogy, adds the ingredients to make a salad, and the order does not matter, but they should all do this:

data SaladState = Initial | AddingIngredients | ReadyToEat

record SaladBowl where
       constructor MkSaladBowl
       lettuce, tomato, cucumber : Bool

data HasIngredient : (ingredient : SaladBowl -> Bool) -> (bowl : SaladBowl ** ingredient bowl = True) -> Type where
     Bowl : HasIngredient ingredient bowl

data HasIngredients : (ingredients : List (SaladBowl -> Bool))
                     -> (bowl : SaladBowl ** (foldl (&&) True (map (\i => i bowl) ingredients) = True)) 
                     -> Type where
     Bowlx : HasIngredients ingredients bowl

data SaladAction : (ty : Type) -> SaladState -> (ty -> SaladState) -> Type where
     GetBowl     : SaladAction SaladBowl Initial (const Initial)
     AddLettuce  : SaladBowl -> SaladAction (bowl ** HasIngredient lettuce bowl)  st (const AddingIngredients)
     AddTomato   : SaladBowl -> SaladAction (bowl ** HasIngredient tomato bowl)   st (const AddingIngredients)
     AddCucumber : SaladBowl -> SaladAction (bowl ** HasIngredient cucumber bowl) st (const AddingIngredients)
     MixItUp     : SaladBowl -> SaladAction (bowl ** (HasIngredients [lettuce, tomato, cucumber] bowl)) AddingIngredients (const ReadyToEat)
     Pure : (res : ty) -> SaladAction ty (state_fn res) state_fn
     (>>=) : SaladAction a state1 state2_fn
           -> ((res : a) -> SaladAction b (state2_fn res) state3_fn)
           -> SaladAction b state1 state3_fn

emptyBowl : SaladBowl
emptyBowl = MkSaladBowl False False False

prepSalad1 : SaladAction SaladBowl Initial (const ReadyToEat)
prepSalad1 = do
           (b1 ** _) <- AddTomato emptyBowl
           (b2 ** _) <- AddLettuce b1
           (b3 ** _) <- AddCucumber b2
           MixItUp b3

And counter examples of programs that the compiler should happen on:

BAD : SaladAction SaladBowl Initial (const ReadyToEat)
BAD = do
           (b1 ** _) <- AddTomato emptyBowl
           (b2 ** _) <- AddTomato emptyBowl
           (b3 ** _) <- AddLettuce b2
           (b4 ** _) <- AddCucumber b3
           MixItUp b4

BAD' : SaladAction SaladBowl Initial (const ReadyToEat)
BAD' = do
           (b1 ** _) <- AddTomato emptyBowl
           MixItUp b1

, "" Sums Bools (data Lettuce = Romaine | Iceberg | Butterhead) , , " , ".

, , , -, ... FSM (PDA?), ? Haskell , , ?

+4
2

, " " " , ?" , : , . , , , .

. . (()) , , . , , Int, a Bool a Char :

type IntBoolChar = ((((), Int), Bool), Char)

, , :

-- we will *not* be using this type like a state monad
addLettuce :: a -> (a, Lettuce)
addLettuce = (, Romaine)

addOlives :: a -> (a, Olive)
addOlives = (, Kalamata)

addCheese :: a -> (a, Cheese)
addCheese = (, Feta)

addGreekSaladIngredients :: a -> (((a, Lettuce), Olive), Cheese)
-- yes, i know you also need tomatoes and onions for a Greek salad. i'm trying to keep the example short
addGreekSaladIngredients = addCheese . addOlives . addLettuce

. . API- #, # currying, Applicative Haskell. : , Add , Build , , , .

, .

data Salad = Salad {
    _lettuce :: Lettuce,
    _olive :: Olive,
    _cheese :: Cheese
}

, , , :

class Has a s where
    has :: Lens' s a

-- this kind of function can be written generically using TH or Generics
toSalad :: (Has Lettuce s, Has Olive s, Has Cheese s) => s -> Salad
toSalad x = Salad (x^.has) (x^.has) (x^.has)

( HasX, lens Haskell.)

, , Has . : , , , - . , : ; , .

, . , . , , .

type family Here a as where
    Here a (_, a) = True
    Here a (_, b) = False

class Has' (here :: Bool) a s where
    has' :: Proxy here -> Lens' s a

instance Has' True a (as, a) where
    has' _ = _2
instance Has a as => Has' False a (as, b) where
    has' _ = _1.has

instance Has' (Here a (as, b)) a (as, b) => Has a (as, b) where
    has = has' (Proxy :: Proxy (Here a (as, b)))

. , newtype. , , , Has . :

toSalad :: (((a, Lettuce), Olive), Cheese) -> Salad
toSalad (((_, l), o), c) = Salad l o c

.

:

greekSalad = toSalad $ addGreekSaladIngredients ()

ghci> greekSalad
Salad {_lettuce = Romaine, _olive = Kalamata, _cheese = Feta}  -- after deriving Show


{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE ScopedTypeVariables #-}

import Control.Lens hiding (has, has')
import Data.Proxy

data Lettuce = Romaine deriving (Show)
data Olive = Kalamata deriving (Show)
data Cheese = Feta deriving (Show)

data Salad = Salad {
    _lettuce :: Lettuce,
    _olive :: Olive,
    _cheese :: Cheese
} deriving (Show)

-- we will *not* be using this type like a state monad
addLettuce :: a -> (a, Lettuce) -- <<< Tuple Sections
addLettuce = (, Romaine)

addOlives :: a -> (a, Olive)
addOlives = (, Kalamata)

addCheese :: a -> (a, Cheese)
addCheese = (, Feta)

addGreekSaladIngredients :: a -> (((a, Lettuce), Olive), Cheese)
addGreekSaladIngredients = addCheese . addOlives . addLettuce

class Has a s where
  has :: Lens' s a

type family Here a as where
    Here a (_, a) = True
    Here a (_, b) = False

class Has' (here :: Bool) a s where
    has' :: Proxy here -> Lens' s a

instance Has' True a (as, a) where
    has' _ = _2

instance Has a as => Has' False a (as, b) where
    has' _ = _1.has

instance  Has' (Here a (as, b)) a (as, b) => Has a (as, b) where -- <<< Undecidable Instances
    has = has' (Proxy :: Proxy (Here a (as, b)))

toSalad :: (Has Lettuce s, Has Olive s, Has Cheese s) => s -> Salad
toSalad x = Salad (x ^. has) (x ^. has) (x ^. has)

greekSalad = toSalad $ addGreekSaladIngredients ()

-- nonSaladsError = toSalad $ (addCheese . addOlives) ()
+3

.

State s ( , ), - s. :

newtype State s a = State { run :: s -> (a, s) }

a -> State s b - a b. (a, s) -> (b, s).

, :

(>>=) :: State s a -> (a -> State s b) -> State s b
m >>= f = State (\s1 -> let (a, s2) = run m s1 in run (f a) s2)

, State s .

( ) . . . IxState i j a , i, j:

newtype IxState i j a = IxState { run :: i -> (a, j) }

State s IxState s s. IxState , State. , , :

(>>>=) :: IxState i j a -> (a -> IxState j k b) -> IxState i k b
m >>>= f = IxState (\s1 -> let (a, s2) = run m s1 in run (f a) s2)

IxState - , .

. - :

mix :: IxState (Salad r) Ready ()

, Salad, r, Ready , .

, :

data Salad xs = Salad
data Ready = Ready
data Lettuce
data Cucumber
data Tomato

.

emptyBowl :: IxState x (Salad '[]) ()
emptyBowl = iput Salad

:

addLettuce :: IxState (Salad r) (Salad (Lettuce ': r)) ()
addLettuce = iput Salad

.

mix :

mix :: IxState (Salad '[Lettuce, Cucumber, Tomato]) Ready ()
mix = const Ready

, , Lettuce, Cucumber Tomato, . . :

emptyBowl >>>= \_ -> addLettuce >>>= \_ -> mix

. , , - - :

class Elem xs x

instance {-# OVERLAPS #-} Elem (x ': xs) x
instance Elem xs x => Elem (y ': xs) x

Elem xs x , x xs. ( ) , x, , x ': xs. , x xs, y ': xs y. OVERLAPS , , Haskell .

:

{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}

import Control.Monad.Indexed
import Control.Monad.Indexed.State

data Lettuce
data Tomato
data Cucumber

data Ready = Ready

class Elem xs x

instance {-# OVERLAPS #-} Elem (x ': xs) x
instance Elem xs x => Elem (y ': xs) x

data Salad xs = Salad

emptyBowl :: IxState x (Salad '[]) ()
emptyBowl = iput Salad

addLettuce :: IxState (Salad r) (Salad (Lettuce ': r)) ()
addLettuce = iput Salad

addTomato :: IxState (Salad r) (Salad (Tomato ': r)) ()
addTomato = iput Salad

addCucumber :: IxState (Salad r) (Salad (Cucumber ': r)) ()
addCucumber = iput Salad

mix :: (Elem r Lettuce, Elem r Tomato, Elem r Cucumber)
    => IxState (Salad r) Ready ()
mix = imodify mix'
  where mix' = const Ready

x >>> y = x >>>= const y

-- Compiles
test = emptyBowl >>> addLettuce >>> addTomato >>> addCucumber >>> mix

-- Fails with a compile-time type error
fail = emptyBowl >>> addTomato >>> mix
+4

Source: https://habr.com/ru/post/1690285/

More articles:


All Articles