diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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: +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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/examples/pronouns/Main.hs b/examples/pronouns/Main.hs new file mode 100644 --- /dev/null +++ b/examples/pronouns/Main.hs @@ -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 diff --git a/examples/slimes/Main.hs b/examples/slimes/Main.hs new file mode 100644 --- /dev/null +++ b/examples/slimes/Main.hs @@ -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) diff --git a/examples/tutorial/Main.hs b/examples/tutorial/Main.hs new file mode 100644 --- /dev/null +++ b/examples/tutorial/Main.hs @@ -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) diff --git a/smarties.cabal b/smarties.cabal new file mode 100644 --- /dev/null +++ b/smarties.cabal @@ -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 +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 diff --git a/src/Smarties.hs b/src/Smarties.hs new file mode 100644 --- /dev/null +++ b/src/Smarties.hs @@ -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 diff --git a/src/Smarties/Base.hs b/src/Smarties/Base.hs new file mode 100644 --- /dev/null +++ b/src/Smarties/Base.hs @@ -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 diff --git a/src/Smarties/Builders.hs b/src/Smarties/Builders.hs new file mode 100644 --- /dev/null +++ b/src/Smarties/Builders.hs @@ -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) diff --git a/src/Smarties/Nodes.hs b/src/Smarties/Nodes.hs new file mode 100644 --- /dev/null +++ b/src/Smarties/Nodes.hs @@ -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) diff --git a/test/unit/BuildersSpec.hs b/test/unit/BuildersSpec.hs new file mode 100644 --- /dev/null +++ b/test/unit/BuildersSpec.hs @@ -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 diff --git a/test/unit/SmartiesSpec.hs b/test/unit/SmartiesSpec.hs new file mode 100644 --- /dev/null +++ b/test/unit/SmartiesSpec.hs @@ -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 diff --git a/test/unit/Spec.hs b/test/unit/Spec.hs new file mode 100644 --- /dev/null +++ b/test/unit/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}