packages feed

smarties (empty) → 1.2.1

raw patch · 15 files changed

+1576/−0 lines, 15 filesdep +MonadRandomdep +QuickCheckdep +basesetup-changed

Dependencies added: MonadRandom, QuickCheck, base, haskeline, hspec, ilist, microlens, microlens-th, mtl, random, smarties, text, vector

Files

+ ChangeLog.md view
@@ -0,0 +1,57 @@+# Changelog for smarties+All notable changes to this project will be documented in this file.++The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/)+and this project adheres to [Semantic Versioning](http://semver.org/spec/v2.0.0.html).++## [1.2.1] - 2020-03-27+### Added+- more tests cases in `Smarties`++### Changed+- renamed `runNodes` to `runNodeSequenceT` to be more consistent with `StateT`+- cleaned up dependencies++## [1.2.0] - 2020-03-26+### Added+- travis CI+- tests cases for `Smarties.Builder`++### Changed+- removed non transformer variant of smarties+- simplified some interfaces+- possibly fixed some bugs.+- improved README.md++## [1.1.0] - 2018-11-07+### Added+- Added `Smarties.Trans` containing Monad Transformer variant `NodeSequenceT`. Currently as separate module for performance reasons. I still have to do side by side benchmarks. I'm pretty sure it's a substantial performance hit especially due to all the extra wrapping/unwrapping that happens in selector nodes.+- Added transformer variants in `Smarties.Trans.Builders`+- Added Conway's Game of Life tutorial to examples+- Haddock comment cleanup++### Changed+- Utility type no longer requires `Num`/`Ord` constraints, these constraints are enforced by the selectors that use them.+- Pronouns moved out of main README.md+- updated Pronouns README.md++### Removed+- Removed `sequence` method. Just use `do` notation+- Removed NotSoSmarties++## [1.0.2] - 2018-05-08+### Added+- This ChangeLog.md file is being updated now.++### Changed+- README.md updated++### Removed+- `TreeState` and `TreeStack` modules both removed. They aren't necessary and their functionality is better done by monadic syntax.++## 1.0.1+### Added+- First proper release++[Unreleased]: https://github.com/pdlla/smarties/compare/v1.0.2...HEAD+[1.0.2]:https://github.com/pdlla/smarties/compare/v1.0.1...v1.0.2
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Author name here (c) 2018++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Author name here nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,68 @@+[![Build Status](https://travis-ci.com/pdlla/smarties.svg?branch=master)](https://travis-ci.com/pdlla/smarties)++# smarties+Smarties is a general purpose [behavior tree](https://en.wikipedia.org/wiki/Behavior_tree_(artificial_intelligence,_robotics_and_control)) (BT) library written in Haskell. The library supports utility AI for advanced decision making. Smarties implements many of the design patterns outlined in this [paper](https://course.ccs.neu.edu/cs5150f13/readings/dill_designpatterns.pdf) and some that aren't.++BTs are written in a DSL built with the **NodeSequence** monad. Monadic return values are used for computing utility and passing state between nodes.++To jump right in, please see the this tutorial example implementing [Conway's Game of Life](https://github.com/pdlla/smarties/tree/master/examples/tutorial). There are other examples in the examples folder that I either put in too little or too much effort.++## Terminology+- **perception**: input and computation state of the BT. Named perception because it represents how the tree perceives the outside world. It's possible to write nodes that modify **perception** so that your BT has mutable perception (or state). Since you are already writing in Haskell, you probably don't ever want to do this.+- **sequence**: control node that executes each child node in sequence until it hits a FAIL node and collects all output.+- **selector**: control node that executes the first SUCCESS node.+- **utility**: optional monadic output for a node that can be used for more complex control flow. For example **utilitySelector** executes the node that has the largest utility.++## Understanding the NodeSequence Monad+**NodeSequence** is a computation that executes all it's internal nodes. At each **>>=** it will check the output and early exit if it reaches a **FAIL**.++**NodeSequence** has the following definition++```haskell+data NodeSequenceT g p o m a =  NodeSequence { runNodeSequenceT :: g -> p -> (a, g, p, Status, [o]) }+```++The sequence represents a computation that takes a generator and perception and returns an output with the following types:++- **a**: monad output type, typically used for computing utility+- **g**: random generator+- **p**: perception type+- **Status**: Status of executing NodeSequence, either **SUCCESS** or **FAIL**+- **o**: output type (or action type)++**NodeSequence** looks a lot like **StateT (p,g) Writer [o]** except with an additional Status output. The difference is that with each **>>=** if the input computation has Status **FAIL**, the monad will stop accumulating changes on **p** and appending to **[o]**. Note that it will continue to pass through **p** and **g** to evaluate the monadic return value **a** which is needed for things like utility selectors. Thus running **NodeSequence** produces an **a** and two thunks representing the perception and output up until the first **FAIL**.++The monadic return value is useful for passing general information between nodes. For example it's possible to implement loops:++```haskell+howQueerIsMyFriend = sequence $ do+	x <- getFriend+	n <- numberFriendsOf x+	clique <- forM [0..(n-1)] (\n' -> do+		s <- getFriendOf x n'+		return queerness s+		)+	return (mean clique)+```++## Builders+Smarties provides the `Smarties.Builders` module for building your own logic nodes which are needed to actually use Smarties in a project. It supports the following types of nodes:++- `Condition`: create a condition node+- `Action`: create an action node+- `Utility`: create a node that returns a utility score+- `Perception`: create a node that modify the perception++Each builder (except for `Perception`) has a simple variant (prefixed by `Simple`) which ensures the **perception** is immutable. You'll want to use the simple variants in most cases.++To keep the syntax simple in most cases, there are non-transformer variants of each builder which wrap the transformer ones.++## Other+- Smarties gives access to the (rather simple) BT control methods in `Smarties.Nodes`. Most of its power comes from the flexibility of monadic syntax. In some cases, it may be better/simpler to use something like **StateT (p,g) Writer [o]**. Sequence and selectors are still possible with monadic operations like [`ifM`](https://hackage.haskell.org/package/extra-1.7.1/docs/Control-Monad-Extra.html).++## Additional Features: <a id="missing"></a>+Some ideas for features to add to this package. I'll probably never get to these but feel free to submit a PR.++- Built in support for [Statistic.Distribution.Normal](https://hackage.haskell.org/package/statistics-0.14.0.2/docs/Statistics-Distribution-Normal.html) for modeling risk reward. This includes [basic](https://en.wikipedia.org/wiki/Sum_of_normally_distributed_random_variables) [operations](https://ccrma.stanford.edu/~jos/sasp/Product_Two_Gaussian_PDFs.html) on distributions.++- It is possible to modify **perception** during tree execution. This is only recommended in the special case where the input state is same as what the tree is operating on as a whole in which case the tree represents a sequential set of operations on a value. e.g. **NodeSequence g Int (Int->Int)** represents operations on an Int value. In these cases, ensure the **SelfActionable p o** constraint is satisfied and use **SelfAction** which is the same as **Action** except also applies the output to the perception. The current implementation is a little idiosyncratic and I may remove in the future so it's mentioned here for now.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ examples/pronouns/Main.hs view
@@ -0,0 +1,145 @@+{-# LANGUAGE TypeSynonymInstances #-}++module Main where+++import           Control.Monad.Random+import           Data.List            (intercalate, mapAccumL)+import           Prelude+import           Smarties++data Pronoun = HeHim | SheHer | TheyThem | FooBar | Other | Undecided deriving (Eq, Show)++data Student = Student {+  assignedPronoun  :: Pronoun,+  preferredPronoun :: Pronoun,+  openlyChange     :: Bool,+  jeans            :: Int+} deriving (Show)++type School = [Student]+type PerceptionType = (School, Student)+type ActionType = (Student -> Student)++assignedPronounIs :: Pronoun -> Student -> Bool+assignedPronounIs p s = assignedPronoun s == p++preferredPronounIs :: Pronoun -> Student -> Bool+preferredPronounIs p s = preferredPronoun s == p++feminimity :: Student -> Float+feminimity = fst . randomR (0.0,1.0) . mkStdGen . (+0) . jeans++masculinity :: Student -> Float+masculinity = fst . randomR (0.0,1.0) . mkStdGen . (+1) . jeans++chromeXX :: Student -> Bool+chromeXX = (<50) . fst . randomR ((0,100)::(Int,Int)) . mkStdGen . (+2) . jeans++chromeXY :: Student -> Bool+chromeXY = (>50) . fst . randomR ((0,100)::(Int,Int)) . mkStdGen . (+2) . jeans++chromeNeither :: Student -> Bool+chromeNeither s = not (chromeXX s) && not (chromeXY s)++noneOfTheAbove :: Student -> Float+noneOfTheAbove = fst . randomR (0.0,1.0) . mkStdGen . (+3) . jeans++developer :: Student -> Float+developer = fst . randomR (0.0,1.0) . mkStdGen . (+4) . jeans++indecisiveness :: Student -> Float+indecisiveness = fst . randomR (0.0,1.0) . mkStdGen . (+5) . jeans++-- totally cool if she or he keeps it him or herself ;)+-- for the purpose of this demo, this is determined by the kind of jeans a student wears. This is not true IRL.+dogmaticBeliefInBinaryBiologicalDeterminism :: Student -> Bool+dogmaticBeliefInBinaryBiologicalDeterminism s = b s && not (chromeNeither s) where+  b = (>99) . fst . randomR ((0,100)::(Int,Int)) . mkStdGen . (+2) . jeans++toZeroOne :: Bool -> Float+toZeroOne x = if x then 1.0 else 0.0++actionChangePronoun :: Pronoun -> NodeSequence g PerceptionType ActionType ()+actionChangePronoun p = fromAction $+  SimpleAction (\_ -> (\(Student a _ _ d) -> Student a p True d))++actionChangeBack :: NodeSequence g PerceptionType ActionType ()+actionChangeBack = fromAction $+  SimpleAction (\_ -> (\(Student a _ c d) -> Student a a c d))++conditionHasProperty :: (Student -> Bool) -> NodeSequence g PerceptionType ActionType ()+conditionHasProperty f = fromCondition $+  SimpleCondition (\(_, st) -> f st)++utilityProperty :: (Student -> Float) -> NodeSequence g PerceptionType ActionType Float+utilityProperty f = fromUtility $+  SimpleUtility (\(_, st) -> f st)++utilityNormalness :: (Student -> Float) -> NodeSequence g PerceptionType ActionType Float+utilityNormalness f = fromUtility $+  SimpleUtility (\(sc, _) -> (sum (map f sc)) / fromIntegral (length sc))++studentTree :: (RandomGen g) => NodeSequence g PerceptionType ActionType Float+studentTree = utilityWeightedSelector+  [return . (*0.2) . (+0.01) =<< utilityWeightedSelector+    [do+      a <- utilityNormalness (toZeroOne . openlyChange)+      b <- utilityProperty feminimity+      actionChangePronoun SheHer+      return $ a * b+    ,do+      a <- utilityNormalness (toZeroOne . openlyChange)+      b <- utilityProperty masculinity+      actionChangePronoun HeHim+      return $ a * b+    ,do+      a <- utilityNormalness (toZeroOne . openlyChange)+      b <- utilityProperty developer+      actionChangePronoun FooBar+      return $ a * b+    ,do+      a <- utilityNormalness (toZeroOne . openlyChange)+      b <- utilityProperty noneOfTheAbove+      actionChangePronoun Other+      return $ a * b+    ,do+      a <- utilityNormalness (toZeroOne . openlyChange)+      m <- utilityProperty masculinity+      f <- utilityProperty feminimity+      actionChangePronoun TheyThem+      return $ a * ((1.0-m)+(1.0-f)) / 2.0+    ]+  ,do+    a <- utilityProperty indecisiveness+    actionChangeBack+    return $ 0.01 * a+  ,do+    a <- utilityNormalness ((1-) . toZeroOne . openlyChange)+    result SUCCESS+    return a+  ]++makeStudent :: (RandomGen g) => Rand g Student+makeStudent = do+  (sJeans::Int) <- getRandom+  (isFemale::Bool) <- getRandom+  let+    pronoun = if isFemale then SheHer else HeHim+  return $ Student pronoun pronoun False sJeans++main :: IO ()+main = do+  stdgen <- getStdGen+  students <- replicateM 10 $ evalRandIO makeStudent+  let+    studentfn g s = (g', (foldl (.) id os) s) where+      (g', _, _, os) = execNodeSequence studentTree g (students, s)+    ticktStudents g sts = mapAccumL studentfn g sts+    loop (0::Int) _ sts = return sts+    loop n g sts = do+      let (g', nextsts) = ticktStudents g sts+      putStrLn . show $ (sum . map (toZeroOne . openlyChange) $ nextsts) --  / (fromIntegral $ length nextsts)+      loop (n-1) g' nextsts+  sts <- loop 365 stdgen students+  putStrLn $ intercalate "\n" $ map (\s -> show (preferredPronoun s) ++ " " ++ show (assignedPronoun s) ++ " " ++ show (openlyChange s)) sts
+ examples/slimes/Main.hs view
@@ -0,0 +1,237 @@+{-|+Module      : Main+Description : Slime Game+Copyright   : (c) Peter Lu, 2018+License     : GPL-3+Maintainer  : chippermonky@gmail.com+Stability   : experimental++Example simulating colony of slimes with feelings using smarties.+Unfinished, not working, and entirely unintuitive. You're welcome to fix it for me :).+-}+++{-# LANGUAGE TypeSynonymInstances           #-}++module Main where++import Smarties+import System.Random+import Control.Concurrent+import Control.Monad hiding (sequence)+import Control.Applicative ((<$>))+import Control.Monad.ST+import Lens.Micro+import Lens.Micro.TH+import Prelude hiding (sequence)+import Data.List+import Data.List.Index (ifoldl)+import Data.Maybe+import qualified Data.Vector as V+import qualified Data.Vector.Mutable as MV+import Text.Printf++type Pos = (Int, Int)++addPos :: Pos -> Pos -> Pos+addPos (x1,y1) (x2,y2) = (x1+x2, y1+y2)++data Feelings = Happy | Sad | Hungry | Apathy deriving (Show, Eq)+data Doings = BlowingBubbles | Eating | Bored deriving (Show)++data Slime = Slime {+  _pos :: Pos,+  _feeling :: Feelings,+  _doings :: Doings,+  _weight :: Int+} deriving (Show)++makeLenses ''Slime++-- world size parameters+width :: Int+width = 20+height :: Int+height = 20+numberCells :: Int+numberCells = width * height+neighbors :: [Pos]+neighbors = [(-1,0),(1,0),(0,-1),(0,1)]+++wrapCoords :: Pos -> Pos+wrapCoords (x,y) = (x `mod` width, y `mod` height)++-- TODO make sure this does what you want with neg coordinates...+wrapFlattenCoords :: Pos -> Int+wrapFlattenCoords (x,y) = (y `mod` height) * width + x `mod` width++-- behavior tree types+type Slimes = [Slime]+type SlimeGrid = V.Vector (Maybe Slime)+type PerceptionType = (SlimeGrid, Slime)++-- slime action is a little weird, for example if the output is [\x->[x],\x->[x]] this will actually make 2 copies of the slime in the same spot.+type ActionType = (Slime -> Slimes)++-- | extract slime that is being operated on from behavior tree perception+getMyself :: NodeSequence g PerceptionType ActionType Slime+getMyself = do+  (_, s) <- getPerception+  return s++-- | extract a neighboring slime+getSlimeRel :: Pos -> NodeSequence g PerceptionType ActionType (Maybe Slime)+getSlimeRel p = do+  (grid, _) <- getPerception+  return $ grid V.! wrapFlattenCoords p++-- | get a list of neigboring slimes+getNeighborSlimes :: NodeSequence g PerceptionType ActionType Slimes+getNeighborSlimes = do+  (grid, s) <- getPerception+  return . mapMaybe ((grid V.!) . wrapFlattenCoords . addPos (_pos s)) $ neighbors++-- behavior tree nodes+-- DELETE+conditionSlimeIsFeeling :: Feelings -> Slime -> NodeSequence g PerceptionType ActionType ()+conditionSlimeIsFeeling f s = fromCondition $+  SimpleCondition (\_ -> _feeling s == f)++actionMoveSlime :: Pos -> NodeSequence g PerceptionType ActionType ()+actionMoveSlime p = fromAction $+  SimpleAction (\_ -> \s -> [set pos (wrapCoords p) s])++-- |+actionMoveSlimeRel :: Pos -> NodeSequence g PerceptionType ActionType ()+actionMoveSlimeRel p = fromAction $+  SimpleAction (\_ -> \s -> [over pos (wrapCoords . addPos p) s])++actionSlime :: NodeSequence g PerceptionType ActionType ()+actionSlime = actionMoveSlimeRel (0,0)++actionCloneSlimeRel :: Pos -> NodeSequence g PerceptionType ActionType ()+actionCloneSlimeRel p = do+  actionMoveSlimeRel p+  actionSlime+++-- | for testing+potatoTree :: NodeSequence g PerceptionType ActionType ()+potatoTree = do+  actionMoveSlimeRel (1,-1)++-- | our behavior tree+slimeTree :: NodeSequence g PerceptionType ActionType ()+slimeTree = do+  nbs <- getNeighborSlimes+  s <- getMyself+  selector [+    -- no neighbors+    do+      condition (null nbs)+      case _feeling s of+        Happy -> actionCloneSlimeRel (1,0)+        Sad -> actionCloneSlimeRel (-1,0)+        Hungry -> actionMoveSlimeRel (0,1)+        _ -> actionSlime+    -- 1 neighbor+    , do+      condition (length nbs == 1)+      let+        nb = head nbs+      case (_feeling nb, _feeling s) of+        (Happy, Happy) -> actionMoveSlimeRel (0,1)+        (Sad, Sad) -> actionCloneSlimeRel (0,-1)+        (Sad, Happy) -> actionMoveSlime (_pos nb)+        _ -> actionSlime+    -- >1 neighbors+    , actionMoveSlimeRel (0,1)+    ]++    -- > 1 neighbor case+    -- don't do anything, this means the slime will die :(+++-- | DELETE+-- our slime action is a special case of behavior tree action type where there should only ever be one action in the output of the tree+-- we do a runtime check here to make sure this is the case+-- unfortunately smarties currently does not support type level checking of this constraint :(.+extractHead :: [ActionType] -> ActionType+extractHead fs+  | null fs = (: [])+  | length fs == 1 = head fs+  | otherwise = error "slime behavior tree must only have one output"++-- | puts slimes in a grid+makeSlimeGrid :: Slimes -> SlimeGrid+makeSlimeGrid slimes = runST $ do+  grid <- MV.replicate numberCells Nothing+  forM_ slimes $ \s@(Slime (x,y) _ _ _) -> MV.write grid (y*width+x) (Just s)+  V.freeze grid++-- | helper for writing slimes to console :)+renderSlime :: Slime -> String+renderSlime (Slime _ f _ _) = case f of+  Happy -> "😊"+  Sad -> "😟"+  Hungry -> "😋"+  Apathy -> "😐"++-- | helper for writing slimes to console :)+renderSlimes :: Slimes -> String+renderSlimes = Data.List.Index.ifoldl func "" . V.toList . makeSlimeGrid where+  func acc i x = output where+    nl = if (i+1) `mod` width == 0 then "\n" else ""+    se = case x of+      Just s -> renderSlime s+      Nothing -> "🌱"+    output = printf "%s%s%s" acc se nl++-- | fuse slimes that share the same cell+fuseSlimes :: Slimes -> Slimes+fuseSlimes slimes =  runST $ do+  grid <- MV.replicate numberCells Nothing+  forM_ slimes $ \s@(Slime (x,y) _ _ w) ->+    MV.modify grid+      (\case+        -- fused slimes just ate each other so they are+        Just (Slime _ _ _ w2) -> Just $ Slime (x,y) Happy Eating (w+w2)+        Nothing -> Just s)+      (y*width+x)+  catMaybes . V.toList <$> V.freeze grid++-- | run slimeTree for each slime collecting results+slimeCycle :: g -> Slimes -> (g, Slimes)+slimeCycle g0 slimes = over _2 (fuseSlimes . concat) (mapAccumL runSlimeTree g0 slimes) where+  -- function to run slime tree over all slimes accumulating the RNG+  runSlimeTree g slime = (g', concat (map ($ slime) os)) where+    (g', _, _, os) = execNodeSequence slimeTree g (makeSlimeGrid slimes, slime)++applyNtimes :: (Num n, Ord n) => n -> (a -> a) -> a -> a+applyNtimes 1 f x = f x+applyNtimes n f x = f (applyNtimes (n-1) f x)+++{-exitLoop :: IO ()+exitLoop = do+  minput <- getInputChar "% "+  case minput of+    Nothing -> return ()+    Just 'q' -> exitSuccess-}++main :: IO ()+main = do+  --forkIO exitLoop+  stdgen <- getStdGen+  let+    genesis = [Slime (0,0) Sad Bored 1] -- 😢+    --outSlimes = applyNtimes 100 (\(g,s) -> slimeCycle g s) (stdgen, genesis)+    cycleOnce (n :: Int) (g,s) = do+      putStrLn "done"+      putStrLn $ renderSlimes s+      let (g',s') = slimeCycle g s+      putStrLn $ "gen " ++ show n+      threadDelay 100000+      cycleOnce (n+1) (g',s')+  cycleOnce 0 (stdgen, genesis)
+ examples/tutorial/Main.hs view
@@ -0,0 +1,153 @@+{-|+Module      : Main+Description : Conway Game of Life example+Copyright   : (c) Peter Lu, 2018+License     : GPL-3+Maintainer  : chippermonky@gmail.com+Stability   : experimental+-}++module Main where++import           Control.Concurrent+import           Control.Monad      hiding (sequence)+import           Data.List+import           Data.List.Index    (ifoldl)+import qualified Data.Vector        as V+import           Prelude            hiding (sequence)+import           Smarties+import           System.Random+import           Text.Printf++-- world size parameters+width :: Int+width = 20+height :: Int+height = 20+numberCells :: Int+numberCells = width * height++-- types+type Pos = (Int, Int)++addPos :: Pos -> Pos -> Pos+addPos (x1,y1) (x2,y2) = (x1+x2, y1+y2)++wrapCoords :: Pos -> Pos+wrapCoords (x,y) = (x `mod` width, y `mod` height)++flattenCoords :: Pos -> Int+flattenCoords (x,y) = y * width + x++wrapFlattenCoords :: Pos -> Int+wrapFlattenCoords = flattenCoords . wrapCoords++indexToPos :: Int -> Pos+indexToPos p = (p `mod` width, p `div` width)++neighbors :: [Pos]+neighbors = [(-1,0),(1,0),(0,-1),(0,1),(1,1),(1,-1),(-1,1),(-1,-1)]++countTrue :: [Bool] -> Int+countTrue = foldl (\acc x -> if x then acc+1 else acc) 0++-- behavior tree types+type Grid = V.Vector Bool+type PerceptionType = (Pos, Grid)+type ActionType = Bool++-- behavior tree methods+countNeighbors  :: NodeSequence g PerceptionType ActionType Int+countNeighbors = do+  (pos, grid) <- getPerception+  return . countTrue . map ((grid V.!) . wrapFlattenCoords . addPos pos) $ neighbors++ifNeighborsMoreThan :: Int -> NodeSequence g PerceptionType ActionType ()+ifNeighborsMoreThan x = do+  n <- countNeighbors+  condition (n > x)++ifNeighborsLessThan :: Int -> NodeSequence g PerceptionType ActionType ()+ifNeighborsLessThan = flipResult . ifNeighborsMoreThan . (\x -> x-1)++die :: NodeSequence g PerceptionType ActionType ()+die = fromAction $ SimpleAction (\_ -> False)++born :: NodeSequence g PerceptionType ActionType ()+born = fromAction $ SimpleAction (\_ -> True)++ifAlive :: NodeSequence g PerceptionType ActionType ()+ifAlive = do+  (pos, grid) <- getPerception+  condition $ grid V.! (wrapFlattenCoords pos)++ifDead :: NodeSequence g PerceptionType ActionType ()+ifDead = flipResult $ ifAlive++-- | our behavior tree+-- note rule 2. is a just a noop (Any live cell with two or three live neighbors lives on to the next generation.)+conwayTree :: NodeSequence g PerceptionType ActionType ()+conwayTree = do+  selector [+    -- rule 1. Any live cell with fewer than two live neighbors dies, as if by underpopulation.+    do+      ifAlive+      ifNeighborsLessThan 2+      die+    -- rule 3. Any live cell with more than three live neighbors dies, as if by overpopulation.+    , do+      ifAlive+      ifNeighborsMoreThan 3+      die+    -- rule 4. Any dead cell with exactly three live neighbors becomes a live cell, as if by reproduction.+    , do+      ifDead+      ifNeighborsMoreThan 2+      ifNeighborsLessThan 4+      born]++-- useful for testing :)+potatoTree :: NodeSequence g PerceptionType ActionType ()+potatoTree = do+  selector [+    do+      ifDead+      born+    , do+      ifAlive+      die]+++-- | helper for writing grid to console :)+renderGrid :: Grid -> String+renderGrid = Data.List.Index.ifoldl func "" . V.toList where+    func acc i x = output where+        nl = if (i+1) `mod` width == 0 then "\n" else ""+        se = case x of+            True  -> "😱"+            False -> "🌱"+        output = printf "%s%s%s" acc se nl+++-- | do conway rules for each grid cell+-- TODO make this run concurrently :). Need to pregen list of generators.+runConway :: g -> Grid -> (g, Grid)+runConway g0 grid = (g', V.zipWith ($) (V.fromList fns) grid) where+  (g', fns) = mapAccumL runTree g0 (map indexToPos [0..numberCells])+  runTree g pos = (g'', if null os then id else \_ -> last os) where+    (g'', _, _, os) = execNodeSequence conwayTree g (pos, grid)++-- | go!+main :: IO ()+main = do+  stdgen <- getStdGen+  let+    genesis = V.fromList . take numberCells $ randoms stdgen+    cycleOnce (n :: Int) (g, s) = do+      putStrLn "done"+      printf "gen %d\n" n+      putStrLn $ renderGrid s+      let (g',s') = runConway g s+      threadDelay 100000+      cycleOnce (n+1) (g',s')+  cycleOnce 0 (stdgen, genesis)
+ smarties.cabal view
@@ -0,0 +1,140 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.31.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: 8fc1a1a4204f99eb8fd360b7d569bfe2b5499d769af1f4e4107dc13e3fa1dca3++name:           smarties+version:        1.2.1+synopsis:       Haskell Behavior Tree Library+description:    Please see the README on Github at <https://github.com/githubuser/smarties#readme>+category:       Games, AI+homepage:       https://github.com/pdlla/smarties#readme+bug-reports:    https://github.com/pdlla/smarties/issues+author:         pdlla+maintainer:     chippermonky@gmail.com+copyright:      2018 Peter Lu+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+  type: git+  location: https://github.com/pdlla/smarties++library+  exposed-modules:+      Smarties+      Smarties.Base+      Smarties.Builders+      Smarties.Nodes+  other-modules:+      Paths_smarties+  hs-source-dirs:+      src+  default-extensions: InstanceSigs LambdaCase GADTs TupleSections ScopedTypeVariables FlexibleInstances MultiParamTypeClasses TemplateHaskell DataKinds TypeFamilies+  ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints+  build-depends:+      MonadRandom+    , QuickCheck >=2.11+    , base >=4.7 && <5.0+    , microlens+    , microlens-th+    , mtl+    , random+    , text+  default-language: Haskell2010++executable pronouns+  main-is: Main.hs+  other-modules:+      Paths_smarties+  hs-source-dirs:+      examples/pronouns+  default-extensions: InstanceSigs LambdaCase GADTs TupleSections ScopedTypeVariables FlexibleInstances MultiParamTypeClasses TemplateHaskell DataKinds TypeFamilies+  ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      MonadRandom+    , QuickCheck >=2.11+    , base >=4.7 && <5.0+    , microlens+    , microlens-th+    , mtl+    , random+    , smarties+    , text+  default-language: Haskell2010++executable slimes+  main-is: Main.hs+  other-modules:+      Paths_smarties+  hs-source-dirs:+      examples/slimes+  default-extensions: InstanceSigs LambdaCase GADTs TupleSections ScopedTypeVariables FlexibleInstances MultiParamTypeClasses TemplateHaskell DataKinds TypeFamilies+  ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      MonadRandom+    , QuickCheck >=2.11+    , base >=4.7 && <5.0+    , haskeline+    , ilist+    , microlens+    , microlens-th+    , mtl+    , random+    , smarties+    , text+    , vector+  default-language: Haskell2010++executable tutorial+  main-is: Main.hs+  other-modules:+      Paths_smarties+  hs-source-dirs:+      examples/tutorial+  default-extensions: InstanceSigs LambdaCase GADTs TupleSections ScopedTypeVariables FlexibleInstances MultiParamTypeClasses TemplateHaskell DataKinds TypeFamilies+  ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      MonadRandom+    , QuickCheck >=2.11+    , base >=4.7 && <5.0+    , ilist+    , microlens+    , microlens-th+    , mtl+    , random+    , smarties+    , text+    , vector+  default-language: Haskell2010++test-suite smarties-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      BuildersSpec+      SmartiesSpec+      Paths_smarties+  hs-source-dirs:+      test/unit+  default-extensions: InstanceSigs LambdaCase GADTs TupleSections ScopedTypeVariables FlexibleInstances MultiParamTypeClasses TemplateHaskell DataKinds TypeFamilies+  ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      MonadRandom+    , QuickCheck >=2.11+    , base >=4.7 && <5.0+    , hspec+    , microlens+    , microlens-th+    , mtl+    , random+    , smarties+    , text+  default-language: Haskell2010
+ src/Smarties.hs view
@@ -0,0 +1,9 @@+module Smarties (+  module Smarties.Base,+  module Smarties.Nodes,+  module Smarties.Builders,+) where++import           Smarties.Base+import           Smarties.Builders+import           Smarties.Nodes
+ src/Smarties/Base.hs view
@@ -0,0 +1,194 @@+{-|+Module      : Base+Description : MTL equivalent of Smarties.Base+Copyright   : (c) Peter Lu, 2018+License     : GPL-3+Maintainer  : chippermonky@gmail.com+Stability   : experimental+-}++module Smarties.Base (+  SelfActionable(..),+  reduce,+  Status(..),+  NodeSequenceT(..),+  execNodeSequenceT,+  execNodeSequenceTimesT,+  execNodeSequenceTimesFinalizeT,+  NodeSequence,+  runNodeSequence,+  execNodeSequence,+  execNodeSequenceTimes,+  execNodeSequenceTimesFinalize,+  getPerception,+  setPerception,+  tellOutput,+  getGenerator,+  setGenerator+  -- $helperlink+) where++import Lens.Micro+import Control.Monad.Random+import Control.Monad.Identity (Identity, runIdentity)+import Control.Applicative+++++--https://ccrma.stanford.edu/~jos/sasp/Product_Two_Gaussian_PDFs.html+--https://en.wikipedia.org/wiki/Sum_of_normally_distributed_random_variables++class SelfActionable p o where+  apply :: o -> p -> p++-- probably {-# OVERLAPPABLE #-}+instance SelfActionable a (a->a) where+  apply = ($)++-- | reduce a list of actions and apply it the perception+reduce :: (SelfActionable p o) => [o] -> p -> p+reduce os p = foldr apply p os++data Status = SUCCESS | FAIL deriving (Eq, Show)++newtype NodeSequenceT g p o m a =  NodeSequenceT { runNodeSequenceT :: g -> p -> m (a, g, p, Status, [o]) }++-- | run a node sequence tossing its monadic output+-- output is ordered from RIGHT to LEFT i.e. foldr when applying+execNodeSequenceT :: (Monad m) => NodeSequenceT g p o m a -> g -> p -> m (g, p, Status, [o])+execNodeSequenceT n g p = (runNodeSequenceT n) g p >>= (\(_,g',p',s,os) -> return (g',p',s,os))++-- | internal helper+iterate_ :: (Monad m) => Int -> (a -> m a) -> a -> m a+iterate_ n f = foldr (>=>) return (replicate n f)++-- | run a node sequence several times using its output to generate the next perception state+execNodeSequenceTimesT :: (SelfActionable p o, Monad m) => Int -> NodeSequenceT g p o m a -> g -> p -> m (g, p, Status, [o])+execNodeSequenceTimesT num n _g _p = iterate_ num itfun (_g, _p, SUCCESS, []) where+  itfun (g,p,_,os) = execNodeSequenceT n g (reduce os p)++-- | same as runNodeSequenceTequenceTimes except reduces the final input with its output and only returns this result+execNodeSequenceTimesFinalizeT :: (SelfActionable p o, Monad m) => Int -> NodeSequenceT g p o m a -> g -> p -> m p+execNodeSequenceTimesFinalizeT num n _g _p = do+  (_,p,_,os) <- execNodeSequenceTimesT num n _g _p+  return $ reduce os p++-- $nontransformerlink++-- | has the exact same interface as the one in Smarties.Base+type NodeSequence g p o a = NodeSequenceT g p o Identity a++-- |+runNodeSequence :: NodeSequence g p o a -> g -> p -> (a, g, p, Status, [o])+runNodeSequence n g p = runIdentity $ runNodeSequenceT n g p++-- |+execNodeSequence :: NodeSequence g p o a -> g -> p -> (g, p, Status, [o])+execNodeSequence n g p = runIdentity $ execNodeSequenceT n g p++-- |+execNodeSequenceTimes :: (SelfActionable p o) => Int -> NodeSequence g p o a -> g -> p -> (g, p, Status, [o])+execNodeSequenceTimes num n g p = runIdentity $ execNodeSequenceTimesT num n g p++-- |+execNodeSequenceTimesFinalize :: (SelfActionable p o) => Int -> NodeSequence g p o a -> g -> p -> p+execNodeSequenceTimesFinalize num n g p = runIdentity $ execNodeSequenceTimesFinalizeT num n g p++-- $helperlink+-- helpers for building NodeSequence in Monad land++-- | returns the perception state+getPerception :: (Monad m) => NodeSequenceT g p o m p+getPerception = NodeSequenceT $ (\g p -> return (p, g, p, SUCCESS, []))++-- | sets the perception state+setPerception :: (Monad m) => p -> NodeSequenceT g p o m ()+setPerception p' = NodeSequenceT $ (\g _ -> return ((), g, p', SUCCESS, []))++-- | add to output+tellOutput :: (Monad m) => o -> NodeSequenceT g p o m ()+tellOutput o = NodeSequenceT $ (\g p -> return ((), g, p, SUCCESS, [o]))++-- | returns the generator+getGenerator :: (Monad m) => NodeSequenceT g p o m g+getGenerator = NodeSequenceT $ (\g p -> return (g, g, p, SUCCESS, []))++-- | set the generator in the monad+setGenerator :: (Monad m) => g -> NodeSequenceT g p o m ()+setGenerator g = NodeSequenceT $ (\_ p -> return ((), g, p, SUCCESS, []))+++-- instance declarations for NodeSequence+-- helpers for building NodeSequence in Monad land++-- |+-- it's possible to do this without Monad m restriction, but reusing >>= is better+instance (Functor m, Monad m) => Functor (NodeSequenceT g p o m) where+  fmap :: (a -> b) -> NodeSequenceT g p o m a -> NodeSequenceT g p o m b+  fmap f n = do+    a <- n+    return $ f a+  --fmap f n = NodeSequenceT func where+  --    func g_ p_ = fmap f' ((runNodeSequenceT n) g_ p_) where+  --        f' (a, g, p, s, os) = (f a, g, p, s, os)+++-- |+-- it's possible to do this without Monad m restriction, but reusing >>= is better+instance (Applicative m, Monad m) => Applicative (NodeSequenceT g p o m) where+  pure a = NodeSequenceT (\g p -> pure (a, g, p, SUCCESS, []))+  liftA2 f n1 n2 = do+    a <- n1+    b <- n2+    return $ f a b++instance (Applicative m, Monad m) => Alternative (NodeSequenceT g p o m) where+  --empty :: NodeSequenceT g p o m a+  empty = NodeSequenceT func where+    func g p = return (error "trying to pull value from a guard", g, p, FAIL, [])+  a <|> b = a >>= \_ -> b++-- | note this looks a lot like (StateT (g,p) Writer o) but has special functionality built in on FAIL+-- note, I'm pretty sure this does not satisfy monad laws+instance (Monad m) => Monad (NodeSequenceT g p o m) where+  (>>=) :: NodeSequenceT g p o m a -> (a -> NodeSequenceT g p o m b) -> NodeSequenceT g p o m b+  NodeSequenceT n >>= f = NodeSequenceT func where+    func g p = do+      -- evaluate the node+      (a, g', p', s, os) <- n g p+      let+        NodeSequenceT n' = f a -- generate the next node+      rslt <- (n' g' p') -- run the next node+      let+        keepGoing = over _5 (++os) rslt+        (b,g'',_,_,_) = keepGoing+      if s == FAIL+       -- if the current node is FAIL:+        -- status is FAIL+        -- perception is input perception+        -- output is empty+        -- rng is accumulated rng from next monad+        -- return monadic return value by dry executing the next monad (passing through updated perception and tossing results)+        -- N.B. if your internal monad encodes side effects, they will not be reverted!+       then return (b, g'', p, FAIL, [])+       else return keepGoing where++instance MonadTrans (NodeSequenceT g p o) where+  lift m = NodeSequenceT (\g p -> m >>= (\a -> return (a, g, p, SUCCESS,[])))++instance (RandomGen g, Monad m) => MonadRandom (NodeSequenceT g p o m) where+  getRandoms = forM [0..] (const getRandom)+  getRandomRs r = forM [0..] (const $ getRandomR r)+  getRandom = do+    g <- getGenerator+    let+      (a, g') = random g+    setGenerator g'+    return a+  getRandomR r = do+    g <- getGenerator+    let+      (a, g') = randomR r g+    setGenerator g'+    return a
+ src/Smarties/Builders.hs view
@@ -0,0 +1,187 @@+{-|+Module      : Builders+Description : MTL equivalent of Smarties.Builders+Copyright   : (c) Peter Lu, 2018+License     : GPL-3+Maintainer  : chippermonky@gmail.com+Stability   : experimental+++-}+module Smarties.Builders (+  -- $helper1link+  Utility(..),+  UtilityT(..),+  Perception(..),+  PerceptionT(..),+  Action(..),+  ActionT(..),+  Condition(..),+  ConditionT(..),+  SelfAction(..),+  SelfActionT(..),+  fromUtility,+  fromUtilityT,+  fromPerception,+  fromPerceptionT,+  fromCondition,+  fromConditionT,+  fromAction,+  fromActionT,+  fromSelfAction,+  fromSelfActionT+) where++import           Smarties.Base+++-- $helper1link+-- helpers for building NodeSequenceT out of functions++-- | Utility return utility only+data Utility g p a where+  Utility :: (g -> p -> (a, g)) -> Utility g p a+  SimpleUtility :: (p -> a) -> Utility g p a++-- | Transformer variant+data UtilityT g p m a where+  UtilityT :: (Monad m) => (g -> p -> m (a, g)) -> UtilityT g p m a+  SimpleUtilityT :: (Monad m) => (p -> m a) -> UtilityT g p m a++-- | Perception modify perception only+data Perception g p where+  Perception :: (g -> p -> (g, p)) -> Perception g p+  SimplePerception :: (p -> p) -> Perception g p+  -- TODO delete this, just use Perception + Conditional, no need to combine them+  ConditionalPerception :: (g -> p -> (Bool, g, p)) -> Perception g p++-- | Transformer variant+data PerceptionT g p m where+  PerceptionT :: (g -> p -> m (g, p)) -> PerceptionT g p m+  SimplePerceptionT :: (p -> m p) -> PerceptionT g p m+  ConditionalPerceptionT :: (g -> p -> m (Bool, g, p)) -> PerceptionT g p m++-- | Actions create output and always have status SUCCESS+data Action g p o where+  Action :: (g -> p -> (g, o)) -> Action g p o+  SimpleAction :: (p -> o) -> Action g p o++-- | Transformer variant+data ActionT g p o m where+  ActionT :: (g -> p -> m (g, o)) -> ActionT g p o m+  SimpleActionT :: (p -> m o) -> ActionT g p o m++-- | Conditions have status SUCCESS if they return true FAIL otherwise+data Condition g p where+  Condition :: (g -> p -> (Bool, g)) -> Condition g p+  SimpleCondition :: (p -> Bool) -> Condition g p++-- | Transformer variant+data ConditionT g p m where+  ConditionT :: (g -> p -> m (Bool, g)) -> ConditionT g p m+  SimpleConditionT :: (p -> m Bool) -> ConditionT g p m++-- | same as Action except output is applied to perception+data SelfAction g p o where+  SelfAction :: (SelfActionable p o) => (g -> p -> (g, o)) -> SelfAction g p o+  SimpleSelfAction :: (SelfActionable p o) => (p -> o) -> SelfAction g p o++-- | same as Action except output is applied to perception+data SelfActionT g p o m where+  SelfActionT :: (SelfActionable p o) => (g -> p -> m (g, o)) -> SelfActionT g p o m+  SimpleSelfActionT :: (SelfActionable p o) => (p -> m o) -> SelfActionT g p o m++-- | convert UtilityT to NodeSequenceT+fromUtilityT :: (Monad m) => UtilityT g p m a -> NodeSequenceT g p o m a+fromUtilityT n = NodeSequenceT $ case n of+  UtilityT f       -> func f+  SimpleUtilityT f -> func (\g p -> f p >>= \x -> return (x, g))+  where+    func f g p = do+      (a, g') <- f g p+      return (a, g', p, SUCCESS, [])++-- |+-- these methods convert to transformer variant+fromUtility :: (Monad m) => Utility g p a -> NodeSequenceT g p o m a+fromUtility n = case n of+  Utility f       -> fromUtilityT $ UtilityT (\g p -> return $ f g p)+  SimpleUtility f -> fromUtilityT $ SimpleUtilityT (return . f)++-- | converts PerceptionT to NodeSequenceT+fromPerceptionT :: (Monad m) => PerceptionT g p m -> NodeSequenceT g p o m ()+fromPerceptionT n = NodeSequenceT $ case n of+  PerceptionT f            -> func f+  SimplePerceptionT f      -> func (\g p -> f p >>= \x -> return (g, x))+  ConditionalPerceptionT f -> cfunc f+  where+    func f g p = do+      (g', p') <- f g p+      return ((), g', p', SUCCESS, [])+    cfunc f g p = do+      (b, g', p') <- f g p+      return ((), g', p', if b then SUCCESS else FAIL, [])++-- |+-- these methods convert to transformer variant+fromPerception :: (Monad m) => Perception g p -> NodeSequenceT g p o m ()+fromPerception n = case n of+  Perception f -> fromPerceptionT $ PerceptionT (\g p -> return $ f g p)+  SimplePerception f -> fromPerceptionT $ SimplePerceptionT (return . f)+  ConditionalPerception f -> fromPerceptionT $ ConditionalPerceptionT (\g p -> return $ f g p)++-- | converts ConditionT to NodeSequenceT+fromConditionT :: (Monad m) => ConditionT g p m -> NodeSequenceT g p o m ()+fromConditionT n = NodeSequenceT $ case n of+  ConditionT f       -> func f+  SimpleConditionT f -> func (\g p -> f p >>= \x -> return (x, g))+  where+    func f g p = do+      (b, g') <- f g p+      return ((), g', p, if b then SUCCESS else FAIL, [])++-- |+-- these methods convert to transformer variant+fromCondition :: (Monad m) => Condition g p -> NodeSequenceT g p o m ()+fromCondition n = case n of+  Condition f       -> fromConditionT $ ConditionT (\g p -> return $ f g p)+  SimpleCondition f -> fromConditionT $ SimpleConditionT (return . f)++-- | converts ActionT to NodeSequenceT+fromActionT :: (Monad m) => ActionT g p o m -> NodeSequenceT g p o m ()+fromActionT n = NodeSequenceT $ case n of+  ActionT f       -> func f+  SimpleActionT f -> func (\g p -> f p >>= \x -> return (g, x))+  where+    func f g p = do+      (g', o) <- f g p+      return ((), g', p, SUCCESS, [o])++-- |+-- these methods convert to transformer variant+fromAction :: (Monad m) => Action g p o -> NodeSequenceT g p o m ()+fromAction n = case n of+  Action f       -> fromActionT $ ActionT (\g p -> return $ f g p)+  SimpleAction f -> fromActionT $ SimpleActionT (return . f)+++++-- | converts SelftActionT to NodeSequenceT+-- WARNING: MAY BE REMOVED IN A FUTURE RELEASE+fromSelfActionT :: (Monad m) => SelfActionT g p o m -> NodeSequenceT g p o m ()+fromSelfActionT n = NodeSequenceT $ case n of+  SelfActionT f       -> func f+  SimpleSelfActionT f -> func (\g p -> f p >>= \x -> return (g, x))+  where+    func f g p = do+      (g', o) <- f g p+      return ((), g', apply o p, SUCCESS, [o])++-- |+-- these methods convert to transformer variant+-- WARNING: MAY BE REMOVED IN A FUTURE RELEASE+fromSelfAction :: (Monad m) => SelfAction g p o -> NodeSequenceT g p o m ()+fromSelfAction n = case n of+  SelfAction f -> fromSelfActionT $ SelfActionT (\g p -> return $ f g p)+  SimpleSelfAction f -> fromSelfActionT $ SimpleSelfActionT (return . f)
+ src/Smarties/Nodes.hs view
@@ -0,0 +1,151 @@+{-|+Module      : Nodes+Description : MTL equivalent of Smarties.Nodes+Copyright   : (c) Peter Lu, 2018+License     : GPL-3+Maintainer  : chippermonky@gmail.com+Stability   : experimental+-}+module Smarties.Nodes (+  -- $controllink+  --sequence,+  selector,+  weightedSelector,+  utilitySelector,+  utilityWeightedSelector,++  -- $decoratorlink+  flipResult,++  -- $conditionlink+  result,+  condition,+  rand++) where++import           Prelude                         hiding (sequence)++import           Smarties.Base++import           Control.Applicative+import           Lens.Micro+import           Control.Monad.Random            hiding (sequence)++import           Data.List                       (find, mapAccumL, maximumBy)+import           Data.Maybe                      (fromMaybe)+import           Data.Ord                        (comparing)+++-- $controllink+-- control nodes++-- | intended use is "sequence $ do"+-- This is prefered over just "do" as it's more explicit.+--sequence :: NodeSequenceT g p o m a -> NodeSequenceT g p o m a+--sequence = id++-- monadic mapAccumR+mapAccumRM :: (Monad m) => (acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])+mapAccumRM f acc_ xs = foldr mapAccumM_ (return (acc_, [])) xs where+  mapAccumM_ x prev = do+    (acc, ys) <- prev+    (acc', y) <- f acc x+    return (acc', ys ++ [y])++-- run a node sequence and return its accumulated generator+-- this is used to mapAccumR over [NodeSequenceT] passing generator through+-- TODO rename this function+mapAccumNodeSequenceT :: (Monad m) => p -> g -> NodeSequenceT g p o m a -> m (g, (a, g, p, Status, [o]))+mapAccumNodeSequenceT p acc x = do+  r <- (runNodeSequenceT x) acc p+  let (_,acc',_,_,_) = r+  return (acc', r)+++-- you can think of selector as something along the lines of (dropWhile SUCCESS . take 1)+selector :: (Monad m) => [NodeSequenceT g p o m a] -> NodeSequenceT g p o m a+selector ns = NodeSequenceT func where+  func g p = do+    (g', rslts) <- mapAccumRM (mapAccumNodeSequenceT p) g ns+    return $ fromMaybe (error "selector: all children failed",g',p,FAIL,[]) $+      find (\(_,_,_,x,_)-> x == SUCCESS) rslts++-- |+weightedSelection :: (RandomGen g, Ord w, Random w, Num w) => g -> [(w,a)] -> (Maybe a, g)+weightedSelection g ns = if total /= 0 then r else weightedSelection g (zip ([0..]::[Int]) . map snd $ ns) where+  (total, nssummed) = mapAccumL (\acc x -> (acc + fst x, (acc + fst x, snd x))) 0 ns+  (rn, g') = randomR (0, total) g+  r = case find (\(w, _) -> w >= rn) nssummed of+    Just (_,n) -> (Just n, g')+    Nothing    -> (Nothing, g')++-- | makes a weighted random selection on a list of nodes and weights+-- this only runs the selected NodeSequence+weightedSelector :: (RandomGen g, Ord w, Num w, Random w, Monad m) => [(w, NodeSequenceT g p o m a)] -> NodeSequenceT g p o m a+weightedSelector ns = NodeSequenceT func where+  func g p = (runNodeSequenceT selectedNode) g' p where+    (msn, g') = weightedSelection g ns+    selectedNode = fromMaybe empty msn++-- | it's easy to forget that utility must be the last monadic return value of a NodeSequence to be understood by utility selectors+-- this type family is used to prevent accidental usage of `instance Ord ()` in utility selectors+type family NotUnit a where+  NotUnit () = 'False+  NotUnit a = 'True++-- | returns the node sequence with maximum utility+-- N.B. that this will dry execute ALL node sequences in the input list so be mindful of performance+utilitySelector :: (Ord a, NotUnit a ~ 'True, Monad m) => [NodeSequenceT g p o m a] -> NodeSequenceT g p o m a+utilitySelector ns = NodeSequenceT func where+  func g p = do+    (g', rslts) <- mapAccumRM (mapAccumNodeSequenceT p) g ns+    let compfn = (\(a,_,_,_,_)-> a)+    if null ns+      then return (error "utilitySelector: no children",g',p,FAIL,[])+      else return $ maximumBy (comparing compfn) rslts++-- | makes a weighted random selection on a list of nodes with weights calculated using their monadic return value+-- N.B.  that this will dry execute ALL node sequences in the input list so be mindful of performance+utilityWeightedSelector :: (RandomGen g, Random a, Num a, Ord a, NotUnit a ~ 'True, Monad m) => [NodeSequenceT g p o m a] -> NodeSequenceT g p o m a+utilityWeightedSelector ns = NodeSequenceT func where+  func g p = do+    (g', rslts) <- mapAccumRM (mapAccumNodeSequenceT p) g ns+    let+      compelt = (\(a,_,_,_,_)->a)+      (selected', g'') = weightedSelection g' $ map (\x-> (compelt x, x)) rslts+    return $ fromMaybe (error "utilityWeightedSelector: no children",g'',p,FAIL,[]) $ do+        n <- selected'+        return $ set _2 g'' n++-- $decoratorlink+-- decorators run a nodesequence and do something with it's results++-- | decorator that flips the status (FAIL -> SUCCESS, SUCCES -> FAIL)+flipResult :: (Monad m) => NodeSequenceT g p o m a -> NodeSequenceT g p o m a+flipResult n = NodeSequenceT func where+    flipr s = if s == SUCCESS then FAIL else SUCCESS+    func g p = do+      rslt <- runNodeSequenceT n g p+      return $ over _4 flipr rslt++-- this is fine and all except if this occurs after a FAILed NodeSequence it will still output so make sure you clearly document that this is the case and why+--traceNode :: (Monad m) => String -> NodeSequenceT g p o m ()+--traceNode msg = NodeSequenceT (\g p -> trace msg $ return ((), g, p, SUCCESS, []))++-- $conditionlink+-- conditions+-- | has given status+result :: (Monad m) => Status -> NodeSequenceT g p o m ()+result s = NodeSequenceT (\g p -> return ((), g, p, s, []))++-- | create a condition node, SUCCESS if true FAIL otherwise+condition :: (Monad m) => Bool -> NodeSequenceT g p o m ()+condition s = NodeSequenceT (\g p -> return ((), g, p, if s then SUCCESS else FAIL, []))++-- | create a node with random status based on input chance+rand :: (RandomGen g, Monad m) => Float -- ^ chance of success ∈ [0,1]+  -> NodeSequenceT g p o m ()+rand rn = do+  r <- getRandomR (0,1)+  guard (r > rn)
+ test/unit/BuildersSpec.hs view
@@ -0,0 +1,77 @@+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# OPTIONS_GHC -fno-warn-type-defaults #-}++module BuildersSpec where++import           Prelude       hiding (sequence)++import           Control.Monad+import           Test.Hspec++import           Smarties+++test_fromUtility_basic :: Expectation+test_fromUtility_basic = status `shouldBe` SUCCESS where+  util n = fromUtility $ Utility (\g _ -> (n, g))+  tree = do+    a <- util 5+    result $ if a == 5 then SUCCESS else FAIL+  (_, _, status, _) = execNodeSequence tree () ()+++test_fromUtility_withUtilitySelector :: Expectation+test_fromUtility_withUtilitySelector = status `shouldBe` FAIL where+  util n = fromUtility $ Utility (\g _ -> (n, g))+  tree = do+    utilitySelector $ [+        (result SUCCESS >> util (1 :: Int))+        , (result FAIL >> util 2)+        , (result SUCCESS >> util 0)+      ]+  (_, _, status, _) = execNodeSequence tree () ()+++test_fromPerception_basic :: Expectation+test_fromPerception_basic = (finalp, status) `shouldBe` (3, SUCCESS) where+  tree1 = fromPerception $ SimplePerception (\p -> (p+1))+  tree2 = fromPerception $ Perception (\g p -> (g, p+2))+  (_, finalp, status, _) = execNodeSequence (tree1 >> tree2) () 0+++test_fromCondition_basic :: Expectation+test_fromCondition_basic = (status1, status2) `shouldBe` (SUCCESS, FAIL) where+  cond1 = fromCondition $ SimpleCondition (\_ -> True)+  cond2 = fromCondition $ Condition (\g _-> (False, g))+  (_, _, status1, _) = execNodeSequence cond1 () ()+  (_, _, status2, _) = execNodeSequence cond2 () ()++test_fromAction_basic :: Expectation+test_fromAction_basic = (status, os) `shouldBe` (SUCCESS, reverse vals) where+  action n = fromAction $ SimpleAction (\_ -> n)+  vals = [0..100]+  tree = forM_ vals action+  (_, _, status, os) = execNodeSequence tree () ()++--test_fromSelfAction_basic :: Expectation+--test_fromSelfAction_basic = r where+--  action n = fromSelfAction $ SelfAction (\g p -> (g, (+n)))+++spec :: Spec+spec = do+  describe "Builders" $ do+    describe "Utility" $ do+      it "passes basic tests" $+        test_fromUtility_basic+      it "works as expected in utilitySelector" $+        test_fromUtility_withUtilitySelector+    describe "Perception" $ do+      it "passes basic tests" $+        test_fromPerception_basic+    describe "Condition" $ do+      it "passes basic tests" $+        test_fromCondition_basic+    describe "Action" $ do+      it "passes basic tests" $+        test_fromAction_basic
+ test/unit/SmartiesSpec.hs view
@@ -0,0 +1,125 @@+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# OPTIONS_GHC -fno-warn-type-defaults #-}+{-# LANGUAGE TemplateHaskell #-}++-- NOTE these tests are almost identical to the ones in SmartiesSpec+-- I wish there was a nice way to reuse code here :\++module SmartiesSpec where++import           Prelude                hiding (sequence)++import           Test.Hspec+import           Test.QuickCheck++import           Control.Monad+import           Control.Monad.Identity (runIdentity)+import           Data.Function+import           Data.List+import           Data.Maybe             (fromMaybe)+import           System.Random++import           Smarties++data BranchType = BrSelector | BrSequence | BrNot deriving (Show)++instance Arbitrary BranchType where+  arbitrary = oneof (fmap return [BrSelector, BrSequence])++data Tree = Leaf Bool | Branch BranchType [Tree] deriving (Show)++-- TODO find better formula for number of branches/children+instance Arbitrary Tree where+  arbitrary = sized tree' where+    tree' 0 = liftM Leaf arbitrary+    tree' n = frequency [+        (1, liftM Leaf arbitrary)+        , (1, liftM2 Branch (return BrNot) subtree2)+        , (3, liftM2 Branch arbitrary subtree)+      ]+      where+        subtree = replicateM n $ tree' (n `div` 2)+        subtree2 = replicateM 1 $ tree' (n `div` 2)+++-- for these examples, the output is designed to operate on the perception+type GeneratorType = ()+type PerceptionType = Int+type OutputType = Int -> Int++-- | action that increases perception by n (used for tracking which node was executed)+addAction :: Int -> NodeSequence GeneratorType PerceptionType OutputType ()+addAction n = fromAction $ SimpleAction (\_ -> (+n))++-- | adds an action that sets perception to n (used for tracking which node was executed)+setAction :: Int -> NodeSequence g PerceptionType OutputType ()+setAction n = fromPerception $ SimplePerception (const n)++prop_selector_basic :: Bool -> Bool+prop_selector_basic b = let+  tree = selector [result FAIL, result FAIL, result FAIL, result FAIL, result FAIL, result FAIL, result FAIL, result (if b then SUCCESS else FAIL)]+  (_,_,_,s,_) = runIdentity $ (runNodeSequenceT tree) () ()+  in if b then s == SUCCESS else s == FAIL+++mostCommon :: Ord a => [a] -> a+mostCommon = head . maximumBy (compare `on` length) . group . sort++test_weightedSelector :: Expectation+test_weightedSelector = mostCommon as `shouldBe` cnt where+  cnt = 10+  geta (a,_,_,_,_) = a+  tree = do+    weightedSelector $ map (\n-> (n, setAction n)) [0..cnt]+    getPerception+  as = geta $ runNodeSequence (forM [0..1000] (\_ -> tree)) (mkStdGen 0) 0++prop_utilitySelector :: [Int] -> Bool+prop_utilitySelector w = r where+  tree = utilitySelector $ map (\n-> addAction n >> return (w!!n)) [0..(length w -1)]+  (_,p,s,os) = execNodeSequence tree () 0+  rslt = reduce os p+  r = if length w == 0+    then s == FAIL+    else rslt == fromMaybe (-1) (findIndex (maximum w ==) w)++test_utilityWeightedSelector :: Expectation+test_utilityWeightedSelector = mostCommon as `shouldBe` cnt where+  cnt = 10+  geta (a,_,_,_,_) = a+  tree = do+    _ <- utilityWeightedSelector $ map (\n-> (setAction n >> return n)) [0..cnt]+    getPerception+  as = geta $ runNodeSequence (forM [0..1000] (\_ -> tree)) (mkStdGen 0) 0++prop_addition :: Int -> (NonNegative Int) -> Bool+prop_addition a (NonNegative b) = execNodeSequenceTimesFinalize b (addAction a) () 0 == a*b++prop_addition_sequence :: Int -> (NonNegative Int) -> Bool+prop_addition_sequence a (NonNegative b) = (reduce os p == a*b) && s == FAIL where+  (_,p,s,os) = execNodeSequence tree () 0+  tree = do+    forM_ [0..(b-1)] (\_->addAction a)+    -- execution should stop here+    result FAIL+    forM_ [0..100] (\_->addAction a)++-- hspec nonsense+spec = do+  describe "selector" $+    it "satisfies basic property test" $+      property prop_selector_basic+  describe "utilitySelector" $+    it "satisfies basic property test" $+      property prop_utilitySelector+  describe "weightedSelector" $+    it "passes basic tests" $+      test_weightedSelector+  describe "utilityWeightedSelector" $+    it "passes basic tests" $+      test_utilityWeightedSelector+  describe "other" $ do+    it "passes addition property test" $+      property prop_addition+    it "passes addition in sequence property test" $+      property prop_addition_sequence
+ test/unit/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}