├── circle.yml ├── Setup.hs ├── .gitignore ├── src ├── LifeGUI.hs ├── Experimental │ ├── Adventure.hs │ ├── Neural.hs │ ├── Connect4.hs │ └── Survive.hs ├── TodoCmd.hs ├── Compact │ ├── Life.hs │ ├── Chatbot.hs │ └── Hangman.hs ├── Util.hs ├── MHMC.hs ├── RPSCmd.hs ├── Todo.hs ├── Recursive.hs ├── RPS.hs ├── Logger.hs ├── Life.hs ├── Chatbot.hs ├── Hangman.hs ├── TodoJS.hs └── TodoJSOld.hs ├── data └── wordlist.txt ├── LICENSE ├── auto-examples.cabal ├── assets └── todo │ └── index.css └── README.md /circle.yml: -------------------------------------------------------------------------------- 1 | machine: 2 | ghc: 3 | version: 7.8.3 4 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /.cabal-sandbox* 2 | /cabal.sandbox.config 3 | /dist 4 | /data/save 5 | /data/mhmcdist.dat 6 | /notes 7 | -------------------------------------------------------------------------------- /src/LifeGUI.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Graphics.Gloss 4 | 5 | main :: IO () 6 | main = play (InWindow "Life" (1, 1) (500, 500)) 7 | white 8 | 1 9 | (0 :: Int) 10 | (\_ -> Blank ) 11 | (\_ w -> w + 10) 12 | (\_ w -> w + 1 ) 13 | -------------------------------------------------------------------------------- /src/Experimental/Adventure.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Data.Map.Strict (Map) 4 | 5 | type RoomID = Int 6 | 7 | data Room = Room { roomID :: RoomID 8 | , roomName :: String 9 | , roomDesc :: String 10 | , roomItems :: [Item] 11 | , roomLinks :: Map String RoomID 12 | } 13 | 14 | data Item = Item 15 | 16 | main :: IO () 17 | main = putStrLn "adventure time!" 18 | 19 | 20 | -------------------------------------------------------------------------------- /data/wordlist.txt: -------------------------------------------------------------------------------- 1 | Apple 2 | Artichoke 3 | Asparagus 4 | Avocado 5 | Bamboo 6 | Banana 7 | Beans 8 | Beet 9 | Blackberry 10 | Blueberry 11 | Bok Choy 12 | Broccoli 13 | Brussels sprouts 14 | Cabbage 15 | Cantaloupe 16 | Carrot 17 | Cauliflower 18 | Celery 19 | Cilantro 20 | Collards 21 | Corn 22 | Cucumber 23 | Eggplant 24 | Fig 25 | Garlic 26 | Ginger 27 | Gourd 28 | Grape 29 | Horseradish 30 | Jackfruit 31 | Kale 32 | Leek 33 | Lentils 34 | Lettuce 35 | Lychee 36 | Mango 37 | Melon 38 | Mushroom 39 | Mustard 40 | Nectarine 41 | Onion 42 | Papaya 43 | Passion Fruit 44 | Peach 45 | Peas 46 | Pear 47 | Pecan 48 | Pepper 49 | Pineapple 50 | Plum 51 | Pomegranate 52 | Potato 53 | Pumpkin 54 | Radish 55 | Raspberry 56 | Rhubarb 57 | Romaine Lettuce 58 | Shallot 59 | Southern pea 60 | Soy bean 61 | Spinach 62 | Squash 63 | Strawberry 64 | Sweet Potato 65 | Tomato 66 | Truffle 67 | Turnip 68 | Waterchestnut 69 | Watermelon 70 | Yam 71 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014 Justin Le 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /src/TodoCmd.hs: -------------------------------------------------------------------------------- 1 | -- | "Todo" 2 | -- 3 | -- A command line client for the todo app in Todo.hs. At every step, has 4 | -- a primitive instruction parser that parses instructions/commands, sends 5 | -- them into the 'Auto', and outputs the resulting Map of tasks in 6 | -- a pretty-ish way. 7 | -- 8 | -- In a GUI, you would have a thread waiting for inputs on a `Chan` queue 9 | -- (using `runOnChan`, for example), and have your GUI elements dump 10 | -- commands into the queue, and render outputs as they come out. 11 | 12 | module Main (main) where 13 | 14 | import Control.Auto 15 | import Control.Monad 16 | import Data.IntMap (IntMap) 17 | import Data.Maybe 18 | import Prelude hiding ((.), id) 19 | import Text.Read 20 | import Todo 21 | import qualified Data.IntMap as IM 22 | 23 | -- | Parse a string input. 24 | parseInp :: String -> Maybe TodoInp 25 | parseInp = p . words 26 | where 27 | p ("A":xs) = Just (IAdd (unwords xs)) 28 | p ("D":n:_) = onId n TEDelete 29 | p ("C":n:_) = onId n (TEComplete True) 30 | p ("U":n:_) = onId n (TEComplete False) 31 | p ("P":n:_) = onId n TEPrune 32 | p ("M":n:xs) = readMaybe n <&> \i -> ITask i (TEModify (unwords xs)) 33 | p _ = Nothing 34 | onId :: String -> TaskCmd -> Maybe TodoInp 35 | onId "*" te = Just (IAll te) 36 | onId n te = readMaybe n <&> \i -> ITask i te 37 | (<&>) :: Functor f => f a -> (a -> b) -> f b 38 | x <&> f = fmap f x 39 | 40 | -- | Just for command line testing use, turning the IntMap into a String. 41 | formatTodo :: IntMap Task -> String 42 | formatTodo = unlines . map format . IM.toList 43 | where 44 | format (n, Task desc compl) = concat [ show n 45 | , ". [" 46 | , if compl then "X" else " " 47 | , "] " 48 | , desc 49 | ] 50 | 51 | main :: IO () 52 | main = void . interactAuto $ Just <$> fromBlips "" -- we need an Interval 53 | . perBlip (fmap formatTodo todoApp) 54 | . emitJusts parseInp 55 | -------------------------------------------------------------------------------- /src/Compact/Life.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Arrows #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | 6 | module Main (main) where 7 | 8 | import Control.Auto hiding (loop) 9 | import Control.Auto.Blip 10 | import Control.Auto.Collection 11 | import Control.Auto.Switch 12 | import Control.Monad.Fix 13 | import Data.List 14 | import Data.Maybe 15 | import Data.Serialize 16 | import GHC.Generics 17 | import Prelude hiding ((.), id) 18 | import System.Console.ANSI 19 | 20 | -- Types 21 | data Cell = Dead | Alive 22 | deriving (Show, Read, Generic) 23 | 24 | type Grid = [[Cell]] 25 | type Neighborhood = [Cell] 26 | 27 | instance Serialize Cell 28 | 29 | -- Starting grid. A glider, a blinker, a boat, and a beehive. 30 | startingGrid :: Grid 31 | startingGrid = readGrid ["_|_|_|_|_|_|_|_|_|_|_|_|" 32 | ,"_|_|_|_|_|_|_|_|_|_|_|_|" 33 | ,"_|_|_|#|_|_|_|#|#|#|_|_|" 34 | ,"_|_|_|_|#|_|_|_|_|_|_|_|" 35 | ,"_|_|#|#|#|_|_|_|_|_|_|_|" 36 | ,"_|_|_|_|_|_|_|_|_|_|_|_|" 37 | ,"_|_|_|_|_|_|_|_|_|_|_|_|" 38 | ,"_|_|_|_|_|_|_|_|_|#|_|_|" 39 | ,"_|_|#|_|_|_|_|_|#|_|#|_|" 40 | ,"_|#|_|#|_|_|_|_|#|_|#|_|" 41 | ,"_|_|#|#|_|_|_|_|_|#|_|_|" 42 | ,"_|_|_|_|_|_|_|_|_|_|_|_|"] 43 | 44 | main :: IO () 45 | main = loop (board startingGrid) 46 | where 47 | loop a = do 48 | Output g a' <- stepAuto a () 49 | clearScreen 50 | putStrLn (showGrid g) 51 | putStrLn "Press Enter to step simulation." 52 | _ <- getLine 53 | () <$ loop a' 54 | 55 | board :: forall m. MonadFix m => Grid -> Auto m () Grid 56 | board g0 = proc _ -> do 57 | rec cells <- chunks c ^<< dZipAuto nop cells0 <<^ concat -< neighbors 58 | let shiftedGrids = map ($ cells) allShifts 59 | neighbors = map transpose . transpose $ shiftedGrids 60 | id -< cells 61 | where 62 | cells0 = concatMap (map cell) g0 63 | c = length . head $ g0 64 | shiftU = rotateList 65 | shiftD = reverse . rotateList . reverse 66 | shiftL = map shiftU 67 | shiftR = map shiftD 68 | allShifts = [ shiftU . shiftL , shiftU , shiftU . shiftR , shiftR 69 | , shiftL , shiftD . shiftL , shiftD , shiftD . shiftR ] 70 | nop = replicate 2 Alive 71 | 72 | cell :: forall m. Monad m => Cell -> Auto m Neighborhood Cell 73 | cell c0 = switchFromF cell' (cell' c0) <<^ length . filter isAlive 74 | where 75 | cell' Alive = (fromBlips Alive &&& id) . tagBlips Dead . became (\n -> n < 2 || n > 3) 76 | cell' Dead = (fromBlips Dead &&& id) . tagBlips Alive . became (== 3) 77 | 78 | isAlive :: Cell -> Bool 79 | isAlive Alive = True 80 | isAlive Dead = False 81 | 82 | showGrid :: Grid -> String 83 | showGrid = unlines . map (concatMap showCell) 84 | where 85 | showCell Alive = "#|" 86 | showCell Dead = "_|" 87 | 88 | readGrid :: [String] -> Grid 89 | readGrid = (map . mapMaybe) readCell 90 | where 91 | readCell '|' = Nothing 92 | readCell '_' = Just Dead 93 | readCell _ = Just Alive 94 | 95 | rotateList :: [a] -> [a] 96 | rotateList = uncurry (flip (++)) . splitAt 1 97 | 98 | chunks :: Int -> [a] -> [[a]] 99 | chunks n = takeWhile (not.null) . unfoldr (Just . splitAt n) 100 | -------------------------------------------------------------------------------- /src/Util.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | -- | Utility functions for experiments 4 | 5 | module Util (dynMapAccumF, mutual, bracketA) where 6 | 7 | import Control.Auto 8 | import Control.Auto.Blip.Internal 9 | import Control.Auto.Core 10 | import Control.Monad.Trans.Class 11 | import Control.Monad.Trans.State 12 | import Data.Foldable 13 | import Data.IntMap (IntMap, Key) 14 | import Data.Serialize (Serialize) 15 | import Data.Traversable 16 | import Prelude hiding ((.), id, sequence, mapM, mapM_) 17 | import qualified Data.IntMap as IM 18 | import qualified Data.Serialize as S 19 | 20 | bracketA :: Monad m 21 | => Auto m (Either a b) c 22 | -> Auto m c b 23 | -> Auto m a c 24 | bracketA a1 a2 = mkAutoM (bracketA <$> resumeAuto a1 <*> resumeAuto a2) 25 | (saveAuto a1 *> saveAuto a2) 26 | $ \x -> do 27 | (y , a1' ) <- stepAuto a1 (Left x) 28 | (z , a2' ) <- stepAuto a2 y 29 | (y', a1'') <- stepAuto a1' (Right z) 30 | return (y', bracketA a1'' a2') 31 | 32 | mutual :: (Monad m, Serialize d) 33 | => Auto m (a, d) c 34 | -> Auto m (b, c) d 35 | -> d 36 | -> Auto m (a, b) (c, d) 37 | mutual a1 a2 z2 = mkAutoM (mutual <$> resumeAuto a1 <*> resumeAuto a2 <*> S.get) 38 | (saveAuto a1 *> saveAuto a2 *> S.put z2) 39 | $ \(x1, x2) -> do 40 | (y1, a1') <- stepAuto a1 (x1, z2) 41 | (y2, a2') <- stepAuto a2 (x2, y1) 42 | return ((y1, y2), mutual a1' a2' y2) 43 | 44 | dynMapAccumF :: forall a b c d k s m. (Monad m, Applicative m, Serialize k) 45 | => (Key -> a -> s -> (b, s)) 46 | -> (Key -> c -> s -> (d, s)) 47 | -> (k -> Interval m b c) 48 | -> a 49 | -> Auto m ((s, IntMap a), Blip [k]) (IntMap d, s) 50 | dynMapAccumF g1 g2 f x0 = go 0 IM.empty IM.empty 51 | where 52 | go i ks as = mkAutoM (do i' <- S.get 53 | ks' <- S.get 54 | as' <- mapM (resumeAuto . f) ks' 55 | return (go i' ks' as') ) 56 | (S.put i *> S.put ks *> mapM_ saveAuto as) 57 | $ \((s0, xs), news) -> do 58 | let newks = zip [i..] (blip [] id news) 59 | newas = (map . second) f newks 60 | newks' = ks `IM.union` IM.fromList newks 61 | newas' = as `IM.union` IM.fromList newas 62 | newc = i + length newks 63 | resMap = zipIntMapWithDefaults (,) Nothing (Just x0) newas' xs 64 | (res, s1) <- runStateT (IM.traverseWithKey t resMap) s0 65 | let ys' = IM.mapMaybe fst res 66 | as' = snd <$> IM.intersection res ys' 67 | ks' = IM.intersection newks' ys' 68 | return ((ys', s1), go newc ks' as') 69 | t :: Key -> (Interval m b c, a) -> StateT s m (Maybe d, Interval m b c) 70 | t k (a0, x0) = do 71 | x1 <- state (g1 k x0) 72 | (y0, a1) <- lift $ stepAuto a0 x1 73 | y1 <- case y0 of 74 | Just y0' -> Just <$> state (g2 k y0') 75 | Nothing -> return Nothing 76 | return (y1, a1) 77 | 78 | type MapMerge m k a b c = (k -> a -> b -> Maybe c) 79 | -> (m a -> m c) 80 | -> (m b -> m c) 81 | -> m a -> m b -> m c 82 | 83 | genericZipMapWithDefaults :: (Monoid (m c), Functor m) 84 | => MapMerge m k a b c 85 | -> (a -> b -> c) -> Maybe a -> Maybe b 86 | -> m a -> m b -> m c 87 | genericZipMapWithDefaults mm f x0 y0 = mm f' zx zy 88 | where 89 | f' _ x y = Just (x `f` y) 90 | zx = case y0 of 91 | Nothing -> const mempty 92 | Just y' -> fmap (`f` y') 93 | zy = case x0 of 94 | Nothing -> const mempty 95 | Just x' -> fmap (x' `f`) 96 | 97 | zipIntMapWithDefaults :: (a -> b -> c) -> Maybe a -> Maybe b -> IntMap a -> IntMap b -> IntMap c 98 | zipIntMapWithDefaults = genericZipMapWithDefaults IM.mergeWithKey 99 | -------------------------------------------------------------------------------- /src/MHMC.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Arrows #-} 2 | 3 | module Main (main) where 4 | 5 | import Control.Auto 6 | import Control.Auto.Collection 7 | import Control.Auto.Generate 8 | import Control.Auto.Process.Random 9 | import Control.Auto.Time 10 | import Control.Monad 11 | import Data.Array.Repa as R 12 | import Data.Array.Repa.Repr.Vector as R 13 | import Data.Array.Repa.Eval as R 14 | import Control.Monad.Fix 15 | import Data.Functor.Identity 16 | import Control.Auto.Core (autoConstr) 17 | import Debug.Trace 18 | import Prelude hiding ((.), id) 19 | import System.Random 20 | 21 | targetDist :: Double -> Double 22 | -- targetDist x = (exp (-((x - 1)**2)) + exp (-((x + 1)**2))) / sqrt (4 * pi) 23 | -- targetDist x = (exp (-((x - 2)**2)) + exp (-((x + 2)**2))) / sqrt (4 * pi) 24 | -- targetDist x = exp (-((x - 2)**2 * 100)) / sqrt (pi / 100) 25 | targetDist x = exp (-((x - 1)**2)) / sqrt pi * 25 26 | {-# INLINE targetDist #-} 27 | 28 | -- TODO: adjust dx to match acceptance rate 29 | 30 | mhmc :: MonadFix m => Double -> Double -> StdGen -> Auto m a (Double, Int) 31 | mhmc x0 dx g = proc _ -> do 32 | rec jump <- stdRands (randomR (-dx, dx)) g1 -< () 33 | 34 | let x' = x + jump 35 | p = targetDist x 36 | p' = targetDist x' 37 | jProb | p' > p = 1 38 | | otherwise = exp (p' - p) 39 | 40 | toJump <- stdRands (randomR (0, 1)) g2 -< () 41 | 42 | let takeJump = toJump < jProb 43 | 44 | x <- delay_ x0 -< if takeJump then x' 45 | else x 46 | 47 | jumps <- accum_ (+) 0 -< if takeJump then 1 else 0 48 | 49 | id -< (x, jumps) 50 | where 51 | (g1, g2) = split g 52 | {-# INLINE mhmc #-} 53 | 54 | mhmc' :: Monad m => Double -> Double -> StdGen -> Auto m a (Double, Int) 55 | mhmc' x0 dx g0 = mkState_ (const f) (x0, 0, g0) 56 | where 57 | f (x, jC, g) = let (jump, g') = randomR (-dx, dx) g 58 | x' = x + jump 59 | p = targetDist x 60 | p' = targetDist x' 61 | jProb | p' > p = 1 62 | | otherwise = exp (p' - p) 63 | (toJump, g'') = randomR (0, 1) g' 64 | takeJump = toJump < jProb 65 | jC' | takeJump = jC + 1 66 | | otherwise = jC 67 | x'' | takeJump = x' 68 | | otherwise = x 69 | in ((x, jC), (x'', jC', g'')) 70 | {-# INLINE mhmc' #-} 71 | 72 | points, burn, skips, steps :: Int 73 | points = 100 74 | skips = 1000 75 | burn = 10 76 | steps = 10 77 | 78 | main :: IO () 79 | main = do 80 | -- g <- newStdGen 81 | -- putStrLn (autoConstr (mhmc 0 0.01 g :: Auto Identity Double (Double, Int))) 82 | -- putStrLn (autoConstr (mhmc' 0 0.01 g :: Auto Identity Double (Double, Int))) 83 | 84 | a0 <- replicateM points $ do 85 | g <- newStdGen 86 | return (head <$> forcer . accelerate skips (fst <$> mhmc 0 0.01 g)) :: IO (Auto' () Double) 87 | 88 | -- let az = zipAuto () a0 89 | -- xs = runIdentity $ do Output _ burned <- stepN burn az [] 90 | -- Output xs' _ <- stepAuto (accelerate steps burned) [] 91 | -- return (last xs') 92 | -- mapM_ print xs 93 | 94 | let ra :: Array V DIM1 (Auto' () Double) 95 | ra = R.fromList (Z :. points) a0 96 | rs :: Array D DIM1 Double 97 | rs = R.map (runIdentity . flip f ()) ra 98 | res :: [Double] 99 | res = R.toList . runIdentity $ computeVectorP rs 100 | ave = sum res / fromIntegral points 101 | print ave 102 | -- mapM_ print res 103 | 104 | f :: Monad m => Auto m a b -> a -> m b 105 | f a x = do 106 | (_, burned) <- stepN burn a x 107 | (xs, _) <- stepAuto (accelerate steps burned) x 108 | return (last xs) 109 | {-# INLINE f #-} 110 | 111 | -- execAutoN :: Monad m => Int -> Auto m a b -> a -> m (Auto m a b) 112 | -- execAutoN n a x = do 113 | -- Output _ a' <- stepN n a x 114 | -- return a' 115 | 116 | -- execAuto :: Monad m => Auto m a b -> a -> m (Auto m a b) 117 | -- execAuto a x = do 118 | -- Output _ a' <- stepAuto a x 119 | -- return a' 120 | -- {-# INLINE execAuto #-} 121 | 122 | stepN :: Monad m => Int -> Auto m a b -> a -> m (b, Auto m a b) 123 | stepN 1 a x = stepAuto a x 124 | stepN n a x = do 125 | (_, a') <- stepAuto a x 126 | stepN (n - 1) a' x 127 | {-# INLINE stepN #-} 128 | 129 | -------------------------------------------------------------------------------- /src/RPSCmd.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE TupleSections #-} 3 | 4 | module Main where 5 | 6 | -- import Text.Read 7 | import Control.Applicative 8 | import Control.Auto.Run 9 | import Control.Concurrent 10 | import Control.Monad (forever, void) 11 | import Data.Foldable 12 | import Data.IntMap.Strict (IntMap, Key) 13 | import Data.Maybe 14 | import Data.Serialize 15 | import Data.Traversable 16 | import Network.Simple.TCP 17 | import RPS 18 | import System.Environment 19 | import qualified Data.IntMap.Strict as IM 20 | 21 | -- main :: IO () 22 | -- main = print Scissors 23 | 24 | -- type GameAuto m = Auto m (ID, Maybe Throw) (Map ID Output) 25 | 26 | main :: IO () 27 | main = withSocketsDo $ do 28 | toServe <- listToMaybe <$> getArgs 29 | case toServe of 30 | Just "client" -> client 31 | _ -> server 32 | 33 | server :: IO () 34 | server = do 35 | socketMap <- newMVar (IM.empty, 0) 36 | inpChan <- newChan :: IO (Chan (ID, Input)) 37 | 38 | void . forkIO . void $ 39 | runOnChan (autoHandler socketMap) inpChan collectGames 40 | serve "127.0.0.1" "4050" (onSocket socketMap inpChan) 41 | where 42 | autoHandler :: MVar (IntMap Socket, Key) -> IntMap Output -> IO Bool 43 | autoHandler socketMap outputs = do 44 | _ <- flip IM.traverseWithKey outputs $ \k o -> do 45 | sock <- IM.lookup k . fst <$> readMVar socketMap 46 | forM_ sock $ \s -> send s (encode o) 47 | return True 48 | onSocket :: MVar (IntMap Socket, Key) 49 | -> Chan (ID, Input) 50 | -> (Socket, SockAddr) 51 | -> IO () 52 | onSocket socketMap inpChan (sock, addr) = do 53 | key <- modifyMVarMasked socketMap (return . addToMap) 54 | putStrLn $ "Connection on " ++ show addr ++ " (id = " ++ show key ++ ")" 55 | forever $ do 56 | inp <- fmap decode <$> recv sock 1024 57 | forM_ inp $ \inp' -> 58 | forM_ inp' $ \inp'' -> do 59 | putStrLn $ "[" ++ show key ++ "] " ++ show inp'' 60 | writeChan inpChan (key, inp'') 61 | where 62 | addToMap (sm, k) = ((sm', k'), k') 63 | where 64 | k' = k + 1 65 | sm' = IM.insert k' sock sm 66 | 67 | client :: IO () 68 | client = connect "127.0.0.1" "4050" $ \(sock, _) -> do 69 | putStrLn "Connected to server!" 70 | waitGame sock 71 | where 72 | waitGame :: Socket -> IO () 73 | waitGame sock = do 74 | send sock (encode IJoin) 75 | putStrLn "Waiting for game..." 76 | Right resp <- decode <$> untilJust (recv sock 1024) :: IO (Either String Output) 77 | putStrLn $ "Game started against " ++ show (oP2Id resp) ++ "!" 78 | inputLoop sock 79 | inputLoop :: Socket -> IO () 80 | inputLoop sock = do 81 | putStrLn "Enter throw: (R/P/S)" 82 | cmd <- untilJust (parseCmd <$> getLine) 83 | putStrLn $ "Sending " ++ show cmd 84 | send sock (encode cmd) 85 | putStrLn "Waiting for opponent..." 86 | (out, msg) <- untilJust $ waitResp sock 87 | case msg of 88 | MsgQuit True -> do 89 | putStrLn "Quit game! Goodbye!" 90 | putStrLn $ "Final " ++ showScore out 91 | MsgQuit False -> do 92 | putStrLn "Opponent has quit!" 93 | putStrLn $ "Final " ++ showScore out 94 | putStrLn "Finding new game..." 95 | waitGame sock 96 | MsgRes w t -> do 97 | putStrLn $ case w of 98 | Just True -> "Opponent threw " ++ show (losesTo t) ++ " and lost! :D" 99 | Just False -> "Opponent threw " ++ show t ++ " and won! :(" 100 | Nothing -> "Opponent threw " ++ show t ++ " to tie. :|" 101 | putStrLn $ showScore out 102 | inputLoop sock 103 | 104 | waitResp :: Socket -> IO (Maybe (Output, Message)) 105 | waitResp sock = do 106 | Right resp <- decode <$> untilJust (recv sock 1024) :: IO (Either String Output) 107 | return ((resp,) <$> oMessage resp) 108 | 109 | parseCmd :: String -> Maybe Input 110 | parseCmd cmd = case words cmd of 111 | "R":_ -> Just $ IThrow Rock 112 | "P":_ -> Just $ IThrow Paper 113 | "S":_ -> Just $ IThrow Scissors 114 | "Q":_ -> Just IQuit 115 | _ -> Nothing 116 | showScore :: Output -> String 117 | showScore out = "Score: " ++ show (oScore1 out) 118 | ++ " - " ++ show (oScore2 out) 119 | ++ " - " ++ show (oTies out) 120 | 121 | untilJust :: IO (Maybe a) -> IO a 122 | untilJust ima = maybe (untilJust ima) return =<< ima 123 | -------------------------------------------------------------------------------- /src/Experimental/Neural.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Arrows #-} 2 | {-# LANGUAGE TupleSections #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | 5 | module Main where 6 | 7 | import Control.Auto 8 | import Data.Profunctor 9 | import Data.Serialize 10 | import Data.Traversable 11 | import Debug.Trace 12 | import Linear.Matrix 13 | import Linear.Metric 14 | import Linear.V1 15 | import Linear.V2 16 | import Linear.V3 17 | import Linear.V4 18 | import Linear.Vector 19 | import Prelude hiding ((.), id) 20 | import System.Random 21 | import qualified Data.List as L 22 | 23 | type Neural m i o = Auto m (Either (i, o) i) o 24 | type UNeural m i o = Auto m i o 25 | type TNeural m i o = Auto m (i, o) o 26 | 27 | fromU :: Monad m 28 | => UNeural m i o 29 | -> Neural m i o 30 | fromU = lmap (either fst id) 31 | 32 | fromT :: (Monad m, Additive o, Num a) 33 | => TNeural m i (o a) 34 | -> Neural m i (o a) 35 | fromT = lmap (either id (, zero)) 36 | 37 | logistic :: Floating a => a -> a -> a -> a 38 | logistic x0 k x = 1 / (1 + exp (-k * (x - x0))) 39 | 40 | -- for weights: outer layer is each output, nested/inner layer is the 41 | -- weights for each input. 42 | 43 | trainNodeFrom :: forall m vi vo. 44 | ( Monad vi 45 | , Applicative vi 46 | , Metric vi 47 | , Additive vi 48 | , Traversable vi 49 | , Num (vi Double) 50 | , Monad vo 51 | , Applicative vo 52 | , Metric vo 53 | , Additive vo 54 | , Traversable vo 55 | -- , Num (vo Double) 56 | , Serialize (vo (vi Double)) 57 | , Show (vo (vi Double)) 58 | , Monad m 59 | ) 60 | => (vo Double -> vo Double) -- map before exit 61 | -> vo (vi Double) -- inner: by-input weights 62 | -- outer: by-output weight sets 63 | -> Neural m (vi Double) (vo Double) 64 | trainNodeFrom outFunc = mkState f 65 | where 66 | dw :: Double 67 | dw = 0.05 68 | wStep :: Double 69 | wStep = 1 70 | -- the types work out :| 71 | nudges :: vo (vi (vo (vi Double))) 72 | nudges = fmap (outer (scaled (pure dw))) (scaled (pure (pure dw))) 73 | f :: Either (vi Double, vo Double) (vi Double) 74 | -> vo (vi Double) 75 | -> (vo Double, vo (vi Double)) 76 | f (Left (input, expected)) weights = 77 | -- traceShow weights' 78 | (outFunc $ weights' !* input, weights') 79 | where 80 | result = outFunc $ weights !* input 81 | resultErr = result `qd` expected 82 | weights' :: vo (vi Double) 83 | weights' = do 84 | nudgeRow <- nudges :: vo (vi (vo (vi Double))) 85 | row <- weights :: vo (vi Double) 86 | return $ do 87 | -- nudgeEl : matrix with a 1 only at the row of this column 88 | nudgeEl <- nudgeRow :: vi (vo (vi Double)) 89 | weight <- row :: vi Double 90 | 91 | let nudged = weights !+! nudgeEl 92 | resNudged = outFunc $ nudged !* input 93 | nudgedErr = resNudged `qd` expected 94 | dErrdW = (nudgedErr - resultErr) / dw 95 | 96 | return (weight - dErrdW * wStep) 97 | f (Right input) weights = (outFunc $ weights !* input, weights) 98 | 99 | testPoints :: [(V4 Double, V3 Double)] 100 | testPoints = map (\[a,b,c,d] -> (V4 a b c d, ws !* V4 a b c d)) 101 | . L.transpose . map (randoms . mkStdGen) 102 | $ [25645,45764,1354,75673] 103 | where 104 | -- ws = V1 (V4 0.05 0.6 0.2 0.15) 105 | ws = V3 (V4 0.05 0.6 0.2 0.15) 106 | (V4 0 0.1 0.2 0.7 ) 107 | (V4 0.4 0.4 0.1 0.1 ) 108 | 109 | asTest :: (Additive vo, Monad m) 110 | => Neural m (vi Double) (vo Double) 111 | -> Neural m (vi Double) (vo Double) 112 | asTest = liftA2 (^-^) (arr (either snd (const zero))) 113 | 114 | testNudge :: V2 (V3 (V2 (V3 Double))) 115 | testNudge = V2 (V3 (V2 (V3 1 0 0) 116 | (V3 0 0 0)) 117 | (V2 (V3 0 1 0) 118 | (V3 0 0 0)) 119 | (V2 (V3 0 0 1) 120 | (V3 0 0 0))) 121 | (V3 (V2 (V3 0 0 0) 122 | (V3 1 0 0)) 123 | (V2 (V3 0 0 0) 124 | (V3 0 1 0)) 125 | (V2 (V3 0 0 0) 126 | (V3 0 0 1))) 127 | 128 | main :: IO () 129 | main = mapM_ print $ streamAuto' (quadrance <$> asTest (trainNodeFrom id w0)) (take 1000 $ map Left testPoints) 130 | where 131 | -- w0 = V1 (V4 0.25 0.25 0.25 0.25) 132 | w0 = V3 (V4 0.25 0.25 0.25 0.25) 133 | (V4 0.25 0.25 0.25 0.25) 134 | (V4 0.25 0.25 0.25 0.25) 135 | 136 | -------------------------------------------------------------------------------- /src/Todo.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Arrows #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE TupleSections #-} 4 | 5 | -- | "Todo" 6 | -- 7 | -- The logic for a simple todo app. It is structured so that its "input" 8 | -- are commands, and its output is a map of tasks to task id's. 9 | -- 10 | -- Hooking it up to a GUI would be as simple as using `runOnChan` from 11 | -- "Control.Auto.Run", and having GUI actions dump commands to the `Chan` 12 | -- queue. 13 | -- 14 | -- A simple command line client is in TodoCmd.hs, and a Javascript client 15 | -- using ghcjs can be found in TodoJS.hs. 16 | -- 17 | -- Supports adding, modifying, "pruning", completing, uncompleting, 18 | -- deleting single or all tasks at a time. 19 | -- 20 | -- Javascript client is online at: 21 | -- http://mstksg.github.io/auto-examples/todo 22 | 23 | module Todo (TaskID, TodoInp(..), TaskCmd(..), Task(..), todoApp) where 24 | 25 | import Control.Auto 26 | import Control.Auto.Collection 27 | import Control.Monad 28 | import Control.Monad.Fix 29 | import Data.IntMap.Strict (IntMap, Key) 30 | import Data.Maybe 31 | import Data.Serialize 32 | import GHC.Generics 33 | import Prelude hiding ((.), id) 34 | import qualified Data.IntMap.Strict as IM 35 | 36 | type TaskID = Key 37 | 38 | -- | An Input event, from the GUI 39 | data TodoInp = IAdd String 40 | | ITask TaskID TaskCmd 41 | | IAll TaskCmd 42 | deriving Show 43 | 44 | -- | Describing a task command 45 | data TaskCmd = TEDelete 46 | | TEPrune 47 | | TEComplete Bool 48 | | TEModify String 49 | deriving Show 50 | 51 | -- | A single task 52 | data Task = Task { taskDescr :: String 53 | , taskCompleted :: Bool 54 | } deriving (Show, Generic) 55 | 56 | instance Serialize Task 57 | 58 | -- | The main Auto. Takes in a stream of input events, and outputs 59 | -- Maps of TaskId's and Tasks. 60 | todoApp :: MonadFix m => Auto m TodoInp (IntMap Task) 61 | todoApp = proc inpEvt -> do 62 | 63 | -- all of the id's of the currently stored tasks, in the IntMap 64 | -- `tmap`. First result will be `[]`. 65 | rec allIds <- arrD IM.keys [] -< tMap 66 | 67 | -- "forking" `inpEvt` into three blip streams: 68 | -- * one blip stream for blips emitting new tasks as strings 69 | newTaskB <- emitJusts getAddEvts -< inpEvt 70 | -- * one blip stream emitting individual targeted commands 71 | modTaskB <- emitJusts getModEvts -< inpEvt 72 | -- * one blip stream emitting "mass" commands 73 | allTaskB <- emitJusts getMassEvts -< (allIds, inpEvt) 74 | 75 | -- merge the two streams together to get "all" inputs, single and 76 | -- mass. 77 | let allInpB = modTaskB <> allTaskB 78 | 79 | -- from a blip stream to an `IntMap` stream that is empty when the 80 | -- stream doesn't emit 81 | allInp <- fromBlips IM.empty -< allInpB 82 | 83 | -- feed the commands and the new tasks to `taskMap`...the result is 84 | -- the `IntMap` of tasks. 85 | tMap <- taskMap -< (allInp, newTaskB) 86 | 87 | id -< tMap 88 | where 89 | -- blip stream filters 90 | getAddEvts :: TodoInp -> Maybe [String] 91 | getAddEvts (IAdd descr) = Just [descr] 92 | getAddEvts _ = Nothing 93 | getModEvts :: TodoInp -> Maybe (IntMap TaskCmd) 94 | getModEvts (ITask n te) = Just $ IM.singleton n te 95 | getModEvts _ = Nothing 96 | getMassEvts :: ([TaskID], TodoInp) -> Maybe (IntMap TaskCmd) 97 | getMassEvts (allIds, IAll te) = Just $ IM.fromList (map (,te) allIds) 98 | getMassEvts _ = Nothing 99 | 100 | 101 | -- | 'Auto' taking an 'IntMap' of task commands, where the key of each 102 | -- command is the ID of the task to send it to. It also takes a blip 103 | -- stream containing strings for new tasks to create. 104 | -- 105 | -- `dynMapF` works to feed the proper command to the proper `taskAuto`, and 106 | -- create new `taskAuto`s on-the-fly with input from the blip stream. 107 | -- 108 | -- A task auto can "delete itself" by outputting `Nothing`. 109 | taskMap :: Monad m => Auto m (IntMap TaskCmd, Blip [String]) (IntMap Task) 110 | taskMap = dynMapF taskAuto Nothing . arr (first (fmap Just)) 111 | where 112 | -- the Auto for each individual task: fold over the folding function 113 | -- `f` for each input, with the current task. Use `Nothing` to signal 114 | -- that it wants to delete itself. 115 | taskAuto :: Monad m => String -> Interval m (Maybe TaskCmd) Task 116 | taskAuto descr = accum f (Just (Task descr False)) 117 | -- `f` updates our task with incoming commands; outputting `Nothing` 118 | -- will end itself. 119 | f :: Maybe Task -> Maybe TaskCmd -> Maybe Task 120 | f (Just t) (Just te) = case te of 121 | TEDelete -> Nothing 122 | TEComplete c -> Just $ t { taskCompleted = c } 123 | TEModify str -> Just $ t { taskDescr = str } 124 | TEPrune | taskCompleted t -> Nothing 125 | | otherwise -> Just t 126 | f t _ = t 127 | -------------------------------------------------------------------------------- /src/Recursive.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Arrows #-} 2 | 3 | module Main (main) where 4 | 5 | import Control.Auto 6 | import Control.Auto.Process 7 | import Data.Maybe (fromMaybe) 8 | import Control.Auto.Time 9 | import Control.Auto.Run 10 | import Control.Monad.Fix 11 | import Prelude hiding ((.), id) 12 | 13 | -- | The Fibonacci sequence, implemented using `delayN`. In this, `z` is 14 | -- `x + y`, where `x` is `z` delayed by two steps, and `y` is `z` delayed 15 | -- by one step. 16 | -- 17 | -- In mathy terms, this means: z_n = z_(n-2) + z_(n-1). 18 | -- 19 | -- We output `x`, which is initially `1`. 20 | -- 21 | -- > delayN :: Int -> a -> Auto m a a 22 | -- 23 | -- `delayN n x` outputs `x` for `n` of the first steps, then outputs 24 | -- whatever it receives, lagging behind `n` steps. 25 | -- 26 | fib :: MonadFix m => Auto m a Int 27 | fib = proc _ -> do 28 | rec x <- (delayN 2) 1 -< z -- z_(n-2) 29 | y <- (delayN 1) 1 -< z -- z_(n-1) 30 | let z = x + y -- z_n 31 | id -< x 32 | 33 | -- | An exponential series: powers of 2. `x + x` is fed to a delayed 34 | -- version of itself. That is, `x` starts at 1; the next value is `1 + 1`, 35 | -- 2; the next value is `2 + 2`, 4, etc. 36 | -- 37 | -- In mathy terms, this algorithm is basically: z_n = z_(n-1) + z_(n-1). 38 | expo :: MonadFix m => Auto m a Int 39 | expo = proc _ -> do 40 | rec x <- delay 1 -< x + x -- z_n = z_(n-1) + z_(n-1) 41 | id -< x 42 | 43 | -- | Real-life example; a "pid" controller is a feedback controller; when 44 | -- you have a black box system with input and output, and you want to get 45 | -- the output to a certain target by varying a control value. You don't 46 | -- know what control corresponds to what output, so you have to "search" 47 | -- for it. People use this for things like figuring out how much power to 48 | -- feed to a heater to make the room a given temperature. 49 | -- 50 | -- PID works by starting with an initial guess, and at every step, 51 | -- adjusting it slightly. It adjusts it by the current error (target minus 52 | -- current response), the cumulative error, and the consecutive 53 | -- differences between the errors. 54 | -- 55 | -- See http://en.wikipedia.org/wiki/PID_controller 56 | -- 57 | -- This algorithm here is implemented by just "defining" these concepts, 58 | -- recursively, and how they are related to each other. Like a graph or 59 | -- network. Just...*state* the relationships, and the auto figures out how 60 | -- to make them happen. No iterative loops, no keeping track of state, 61 | -- etc. 62 | -- 63 | -- Note that here we use `sumFromD` for the control, instead of `sumFrom`. 64 | -- That's because for recursive bindings like these, we need at least one 65 | -- `Auto` to be able to give a "initial response" without considering any 66 | -- input...just to "start off" the cycle. `sumFromD` always outputs its 67 | -- initial accumulator first, so it doesn't need any input to output 68 | -- immediately; it begins the chain of evaluation. This is an important 69 | -- key to remember when doing any recursive bindings --- you need at least 70 | -- one thing to "start" the chain of evaluation that doesn't depend 71 | -- immediately on anything else. 72 | -- 73 | -- Anyways, here we represent a system as `System`, an `Auto` that takes 74 | -- stream of `Double`s as input and transforms it into a stream of 75 | -- `Double`s as output. The `m` means that a `System IO` might do IO in 76 | -- the process of creating its ouputs, for instance. 77 | -- 78 | type System m = Auto m Double Double 79 | 80 | pid :: MonadFix m => Double -> (Double, Double, Double) -> System m -> System m 81 | pid c0 (kp, ki, kd) blackbox = proc target -> do 82 | rec -- err :: Double 83 | -- the difference of the response from the target 84 | let err = target - response 85 | 86 | -- cumulativeSum :: Double 87 | -- the cumulative sum of the errs 88 | cumulativeSum <- sumFrom 0 -< err 89 | 90 | -- changes :: Maybe Double 91 | -- the consecutive differences of the errors, with 'Nothing' at first. 92 | changes <- deltas -< err 93 | 94 | -- adjustment :: Double 95 | -- the adjustment term, from the PID algorithm 96 | let adjustment = kp * err 97 | + ki * cumulativeSum 98 | + kd * fromMaybe 0 changes 99 | 100 | -- the control input is the cumulative sum of the adjustments 101 | -- sumFromD so that it can output its first value immediately (c0), 102 | -- and begin the chain of recursive evaluation. 103 | control <- sumFromD c0 -< adjustment 104 | 105 | -- the response of the system, feeding the control into the blackbox 106 | response <- blackbox -< control 107 | 108 | id -< response 109 | 110 | main :: IO () 111 | main = do 112 | putStrLn ">>> Fibs!" 113 | print . evalAutoN' 20 fib $ () 114 | putStrLn ">>> Expo!" 115 | print . evalAutoN' 20 expo $ () 116 | putStrLn ">>> PID!" 117 | let blackbox = arr (\x -> exp x + sin x * 10 + cosh x * 5) 118 | print . evalAutoN' 20 (round' <$> pid 0 (0.01, 0.005, 0.001) blackbox) 119 | $ 100 120 | putStrLn "look at that convergence! beautiful!" 121 | where 122 | round' :: Double -> Integer 123 | round' = round 124 | 125 | 126 | -------------------------------------------------------------------------------- /src/RPS.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE Arrows #-} 4 | {-# LANGUAGE TupleSections #-} 5 | 6 | module RPS where 7 | 8 | -- import Control.Auto.Core 9 | -- import Control.Auto.Switch 10 | -- import Data.Set (Set) 11 | -- import qualified Data.Set as S 12 | import Control.Auto 13 | import Control.Auto.Blip 14 | import Control.Auto.Collection 15 | import Control.Auto.Interval 16 | import Control.Monad.Fix 17 | import Data.IntMap.Strict (IntMap) 18 | import Data.List 19 | import Data.Map.Strict (Map) 20 | import Data.Maybe 21 | import Data.Serialize 22 | import GHC.Generics 23 | import Prelude hiding ((.), id) 24 | import qualified Data.IntMap.Strict as IM 25 | import qualified Data.Map.Strict as M 26 | 27 | data Throw = Rock | Paper | Scissors 28 | deriving (Show, Eq, Enum, Read, Ord, Generic) 29 | 30 | data Message = MsgRes (Maybe Bool) Throw 31 | | MsgQuit Bool 32 | deriving (Show, Generic) 33 | 34 | data Input = IThrow Throw 35 | | IQuit 36 | | IJoin 37 | | INop 38 | deriving (Show, Generic) 39 | 40 | data Output = Output { oP1Id :: ID 41 | , oP2Id :: ID 42 | , oP1Gone :: Bool 43 | , oP2Gone :: Bool 44 | , oScore1 :: Int 45 | , oScore2 :: Int 46 | , oTies :: Int 47 | , oMessage :: Maybe Message 48 | } deriving (Show, Generic) 49 | 50 | instance Serialize Throw 51 | instance Serialize Output 52 | instance Serialize Message 53 | instance Serialize Input 54 | 55 | checkThrows :: Throw -> Throw -> Maybe Bool 56 | checkThrows Rock Paper = Just False 57 | checkThrows Rock Scissors = Just True 58 | checkThrows Paper Rock = Just True 59 | checkThrows Paper Scissors = Just False 60 | checkThrows Scissors Rock = Just False 61 | checkThrows Scissors Paper = Just True 62 | checkThrows _ _ = Nothing 63 | 64 | losesTo :: Throw -> Throw 65 | losesTo Rock = Scissors 66 | losesTo Paper = Rock 67 | losesTo Scissors = Paper 68 | 69 | beatenBy :: Throw -> Throw 70 | beatenBy Rock = Paper 71 | beatenBy Paper = Scissors 72 | beatenBy Scissors = Rock 73 | 74 | type ID = Int 75 | 76 | collectGames :: MonadFix m => Auto m (ID, Input) (IntMap Output) 77 | collectGames = proc (k, inp) -> do 78 | rec currGames <- arrD M.keys [] -< gameOuts 79 | 80 | let isInGame = find (\(x, y) -> k == x || k == y) currGames 81 | askNewB <- emitOn isNothing -< isInGame 82 | 83 | mkNewGame <- asMaybes . mapMaybeB id 84 | . perBlip (mkState waiting Nothing) -< k <$ askNewB 85 | 86 | let gameInpK = isInGame <|> mkNewGame 87 | gameInp = maybe M.empty (`M.singleton` (k, inp)) gameInpK 88 | 89 | gameOuts <- gatherMany (uncurry game) -< gameInp 90 | 91 | id -< maybe IM.empty (getOuts gameOuts) gameInpK 92 | where 93 | getOuts :: Map (ID, ID) Output -> (ID, ID) -> IntMap Output 94 | getOuts mp k@(k1, k2) = IM.fromList $ case M.lookup k mp of 95 | Just o -> [(k1, o), (k2, invertOutput o)] 96 | Nothing -> [] 97 | waiting k st = case st of 98 | Just k' | k /= k' -> (Just (k', k), Nothing) 99 | | otherwise -> (Nothing , Just k') 100 | Nothing -> (Nothing, Just k) 101 | invertOutput :: Output -> Output 102 | invertOutput (Output {..}) = Output oP2Id oP1Id 103 | oP2Gone oP1Gone 104 | oScore2 oScore1 oTies 105 | (fmap invertMessage oMessage) 106 | where 107 | invertMessage (MsgRes p thr) = MsgRes (not <$> p) thr 108 | invertMessage (MsgQuit p) = MsgQuit (not p) 109 | 110 | 111 | game :: Monad m => ID -> ID -> Interval m (ID, Input) Output 112 | game p1 p2 = proc (i, inp) -> do 113 | 114 | quitB <- emitOn isQuit -< inp 115 | p1B <- emitJusts (getThrow p1) -< (i, inp) 116 | p2B <- emitJusts (getThrow p2) -< (i, inp) 117 | 118 | -- emitted when both throw finally 119 | throwsB <- collectB -< (p1B, p2B) 120 | 121 | p1Gone <- holdWith False -< mergeLs [False <$ throwsB, True <$ p1B] 122 | p2Gone <- holdWith False -< mergeLs [False <$ throwsB, True <$ p2B] 123 | 124 | let resultB = score <$> throwsB 125 | 126 | p1Score <- scanB (+) 0 -< fst . fst <$> resultB 127 | p2Score <- scanB (+) 0 -< snd . fst <$> resultB 128 | ties <- scanB (+) 0 -< snd <$> resultB 129 | 130 | let messageScore = messageFrom <$> throwsB 131 | 132 | message <- asMaybes -< messageScore 133 | 134 | let out = Output p1 p2 p1Gone p2Gone p1Score p2Score ties message 135 | 136 | before -?> fade -< (out, (i == p1) <$ quitB) 137 | where 138 | getThrow p (i, IThrow x) | i == p = Just x 139 | getThrow _ _ = Nothing 140 | isQuit IQuit = True 141 | isQuit _ = False 142 | score (t1, t2) = case checkThrows t1 t2 of 143 | Just True -> ((1, 0), 0) 144 | Just False -> ((0, 1), 0) 145 | Nothing -> ((0, 0), 1) 146 | messageFrom (t1, t2) = case checkThrows t1 t2 of 147 | Just True -> MsgRes (Just True) t1 148 | Just False -> MsgRes (Just False) t2 149 | Nothing -> MsgRes Nothing t2 150 | fade = proc (o, w) -> do 151 | quitter <- hold -< w 152 | onFor 1 -< o { oMessage = MsgQuit <$> quitter } 153 | 154 | 155 | -------------------------------------------------------------------------------- /src/Compact/Chatbot.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE Arrows #-} 3 | {-# LANGUAGE TupleSections #-} 4 | {-# OPTIONS -fno-warn-orphans #-} 5 | 6 | module Main (main) where 7 | 8 | import Control.Auto 9 | import Control.Auto.Blip 10 | import Control.Auto.Serialize 11 | import Control.Auto.Switch 12 | import Control.Concurrent 13 | import Control.Exception 14 | import Control.Monad 15 | import Control.Monad.IO.Class 16 | import Data.Map.Strict (Map) 17 | import Data.Serialize 18 | import Data.Time 19 | import Network.SimpleIRC 20 | import Prelude hiding ((.), id) 21 | import qualified Data.ByteString.Char8 as C8 22 | import qualified Data.Map.Strict as M 23 | 24 | type ChatBot m = Auto m InMessage OutMessages 25 | type ChatBot' m = Auto m InMessage [String] 26 | 27 | type Nick = String 28 | type Channel = String 29 | 30 | data InMessage = InMessage { _inMessageNick :: Nick 31 | , _inMessageBody :: String 32 | , _inMessageSource :: Channel 33 | , _inMessageTime :: UTCTime 34 | } deriving Show 35 | 36 | newtype OutMessages = OutMessages { _outMessageMap :: Map Channel [String] } 37 | 38 | instance Monoid OutMessages where 39 | mempty = OutMessages M.empty 40 | mappend (OutMessages a) (OutMessages b) = OutMessages (M.unionWith (<>) a b) 41 | 42 | botName :: Nick 43 | botName = "autobot-test" 44 | 45 | channels :: [Channel] 46 | channels = ["#autobot-test"] 47 | 48 | chatbotFP :: FilePath 49 | chatbotFP = "data/save/chatbot" 50 | 51 | main :: IO () 52 | main = launchIRC chatBot 53 | 54 | chatBot :: MonadIO m => ChatBot m 55 | chatBot = mconcat [ s "seen" $ perRoom seenBot -- seenBot, self-serializing 56 | , perRoom karmaBot 57 | , s "ann" announceBot 58 | ] 59 | where 60 | s fp = serializing' (chatbotFP ++ "-" ++ fp) 61 | 62 | perRoom :: Monad m => ChatBot' m -> ChatBot m 63 | perRoom cb' = proc im -> do 64 | outs <- cb' -< im 65 | id -< OutMessages $ M.singleton (_inMessageSource im) outs 66 | 67 | seenBot :: Monad m => ChatBot' m 68 | seenBot = proc (InMessage nick msg _ time) -> do 69 | seens <- accum (\m (n, t) -> M.insert n t m) M.empty -< (nick, time) 70 | id -< case words msg of 71 | "@seen":req:_ -> 72 | [ case M.lookup req seens of 73 | Just t -> "'" ++ req ++ "' last seen at " ++ show t ++ "." 74 | Nothing -> "No record of '" ++ req ++ "'." ] 75 | _ -> 76 | mzero 77 | 78 | karmaBot :: Monad m => ChatBot' m 79 | karmaBot = proc (InMessage _ msg _ _) -> do 80 | karmaBlip <- emitJusts comm -< msg 81 | karmas <- scanB (\m (n, c) -> M.insertWith (+) n c m) M.empty -< karmaBlip 82 | let outBlip = flip fmap karmaBlip $ \(nick, _) -> 83 | let karm = M.findWithDefault 0 nick karmas 84 | in ["'" ++ nick ++ "' has a karma of " ++ show karm ++ "."] 85 | fromBlips mzero -< outBlip 86 | where 87 | comm :: String -> Maybe (Nick, Int) 88 | comm msg = case words msg of 89 | "@addKarma":nick:_ -> Just (nick, 1 ) 90 | "@subKarma":nick:_ -> Just (nick, -1) 91 | "@karma":nick:_ -> Just (nick, 0) 92 | _ -> Nothing 93 | 94 | announceBot :: forall m. Monad m => ChatBot m 95 | announceBot = proc im@(InMessage _ _ src time) -> do 96 | annBlip <- emitJusts announcing -< im 97 | newDay <- onChange -< utctDay time 98 | let annNick = fst <$> annBlip 99 | amnts <- resetOn counter -< (annNick, newDay) 100 | let outmsgs = fmap (\(nick, ann) -> 101 | let amt = M.findWithDefault 0 nick amnts 102 | msgs | amt <= floodLimit = (, [ann]) <$> channels 103 | | otherwise = [(src, ["No Flooding!"])] 104 | in OutMessages (M.fromList msgs) 105 | ) annBlip 106 | fromBlips mempty -< outmsgs 107 | where 108 | floodLimit :: Int 109 | floodLimit = 3 110 | announcing (InMessage nick msg _ _) = 111 | case words msg of 112 | "@ann":ann -> Just (nick, nick ++ " says, \"" ++ unwords ann ++ "\".") 113 | _ -> Nothing 114 | counter = scanB (\m n -> M.insertWith (+) n 1 m) M.empty 115 | 116 | instance Serialize UTCTime where 117 | get = read <$> get -- haha don't do this in real life. 118 | put = put . show 119 | 120 | instance Serialize Day where 121 | get = ModifiedJulianDay <$> get 122 | put = put . toModifiedJulianDay 123 | 124 | ircConf :: MVar (ChatBot IO) -> IrcConfig 125 | ircConf a = (mkDefaultConfig "irc.freenode.org" botName) 126 | { cChannels = channels 127 | , cEvents = [Privmsg (onMessage a)] 128 | } 129 | 130 | launchIRC :: ChatBot IO -> IO () 131 | launchIRC a0 = do 132 | amvr <- newMVar a0 133 | let launch = connect (ircConf amvr) False True 134 | void launch `catch` \(_ :: AsyncException) -> return () 135 | 136 | onMessage :: MVar (ChatBot IO) -> EventFunc 137 | onMessage amvr server msg = do 138 | OutMessages resps <- modifyMVar amvr $ \a -> 139 | case (mNick msg, mOrigin msg) of 140 | (Just nick, Just orig) -> do 141 | t <- getCurrentTime 142 | let inmsg = InMessage (C8.unpack nick) (C8.unpack (mMsg msg)) 143 | (C8.unpack orig) t 144 | (out, a') <- stepAuto a inmsg 145 | return (a', out ) 146 | _ -> 147 | return (a , mempty) 148 | _ <- flip M.traverseWithKey resps $ \k v -> 149 | mapM_ (sendMsg server (C8.pack k) . C8.pack) v 150 | return () 151 | 152 | -------------------------------------------------------------------------------- /src/Logger.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Arrows #-} 2 | 3 | module Main (main) where 4 | 5 | -- | Logger 6 | -- 7 | -- Mostly used to demonstrate "automatic serialization". Using the 8 | -- `serializing` combinator, we transform a normal auto representing 9 | -- a logging process into an auto that automatically, implicitly, and 10 | -- constantly serializes itself...and automatically re-loads the saved 11 | -- state on the program initialization. 12 | -- 13 | -- Demonstrates also `resetFrom`, which is a basic switcher that allows an 14 | -- `Auto` to "reset" itself through an output blip stream. 15 | -- 16 | -- Also heavy usage of "blip stream" logic and intervals to sort out and 17 | -- manage the stream of inputs into streams that do things and create 18 | -- outputs. 19 | 20 | import Control.Auto 21 | import Control.Auto.Blip 22 | import Control.Auto.Core (unserialize) 23 | import Control.Auto.Interval 24 | import Control.Auto.Run 25 | import Control.Auto.Serialize 26 | import Control.Auto.Switch 27 | import Control.Monad (void) 28 | import Data.Time 29 | import Data.Traversable (mapM) 30 | import Prelude hiding (id, (.), log, mapM) 31 | import System.Locale hiding (defaultTimeLocale) 32 | 33 | -- Commands that can be sent into our logger 34 | data LogCmd = CHistory 35 | | CQuit 36 | | CClear 37 | | CLog String 38 | deriving (Show, Eq) 39 | 40 | -- Saving filepath; could be taken from stdin too. 41 | loggingFP :: FilePath 42 | loggingFP = "data/save/logger" 43 | 44 | main :: IO () 45 | main = do 46 | putStrLn "<< @history for history >>" 47 | putStrLn "<< @quit to quit >>" 48 | putStrLn "<< @clear to clear >>" 49 | putStrLn "<< type anything to log >>" 50 | 51 | -- run the self-serializing `loggerReset` `Auto`, with the given 52 | -- initial input functions and processing functions 53 | void . run getInp processOut $ serializing' loggingFP loggerReset 54 | where 55 | getInp = liftA2 (,) getLine getCurrentTime 56 | processOut = mapM $ \str -> putStrLn str *> getInp 57 | 58 | 59 | -- loggerReset wraps around `logger` --- listens on the blip stream coming 60 | -- from `logger`, and resets logger when it emits 61 | loggerReset :: Monad m => Interval m (String, UTCTime) String 62 | loggerReset = resetFrom logger 63 | 64 | -- logger auto. Takes in strings to log, or commands. Outputs a `Maybe 65 | -- String`, with `Nothing` when it's "done"/quitting. Also outputs 66 | -- a 'Blip' that tells 'loggerSwitch' to swap out for a fresh logger 67 | -- auto. 68 | logger :: Monad m 69 | => Auto m (String, UTCTime) (Maybe String, Blip ()) 70 | -- ^ ^ ^ ^ 71 | -- | | | +-- tell `loggerReset` to 72 | -- | | | reset `logger` 73 | -- | | +-- Command line output. Nothing means quit 74 | -- | +-- Time of the command 75 | -- +-- Command line input 76 | logger = proc (input, time) -> do 77 | -- primitive command parser 78 | let cmd = case words input of 79 | "@history":_ -> CHistory 80 | "@quit":_ -> CQuit 81 | "@clear":_ -> CClear 82 | _ -> CLog input 83 | 84 | -- forking the "command" stream into four different blip streams that 85 | -- emit when the command matches their respective streams. 86 | -- Note that for the first three we don't even care what the emitted 87 | -- values are...just *when* they are emitted. 88 | histB <- emitOn (== CHistory) -< cmd 89 | quitB <- emitOn (== CQuit) -< cmd 90 | clearB <- emitOn (== CClear) -< cmd 91 | logB <- emitJusts getLogCmd -< cmd 92 | 93 | -- accumulate the log when `logB` emits, with a logging string. apply 94 | -- `formatLog time` to the emitted value, first. 95 | log <- scanB (++) [] -< formatLog time <$> logB 96 | 97 | -- `outputB` is a blip stream that emits when any of these three 98 | -- streams emit, with the values we are "tagging"/replacing the 99 | -- streams with with `(<$)`. 100 | let outputB = mergeLs [ displayLog log <$ histB 101 | , "Logged." <$ logB 102 | , "Cleared!" <$ clearB 103 | ] 104 | 105 | -- the actual output message will be the last seen message from 106 | -- `outputB`. 107 | outputMsg <- holdWith "" -< outputB 108 | 109 | -- output will be `Just outputMsg`, until `quitB` emits. 110 | -- we "unserialize" before, because we want the whole thing to start 111 | -- over when we reload/resume the program. Alternatively, we can 112 | -- also do: 113 | -- 114 | -- output <- between -< (outputMsg, (outputB, quitB)) 115 | -- 116 | -- so that the output is "turned back on" whenever `outputB` emits. 117 | -- 118 | -- output :: Maybe String 119 | output <- unserialize before -< (outputMsg, quitB) 120 | 121 | id -< (output, () <$ clearB) 122 | 123 | where 124 | -- get a LogCmd's string, if there is one. Used for `emitJusts`. 125 | getLogCmd :: LogCmd -> Maybe String 126 | getLogCmd (CLog str) = Just str 127 | getLogCmd _ = Nothing 128 | 129 | formatLog :: UTCTime -> String -> [String] 130 | formatLog time str = [format time <> " " <> str] 131 | 132 | format :: UTCTime -> String 133 | format = formatTime defaultTimeLocale "<%c>" 134 | 135 | 136 | -- "pretty print" the log 137 | displayLog :: [String] -> String 138 | displayLog log = "Log length: " <> show loglength 139 | <> "\n--------\n" 140 | <> unlines log 141 | <> "--------\n" 142 | <> "Done." 143 | where 144 | loglength = length log 145 | -------------------------------------------------------------------------------- /src/Life.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Arrows #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | 6 | module Main (main) where 7 | 8 | import Control.Auto 9 | import Control.Auto.Blip 10 | import Control.Auto.Collection 11 | import Control.Auto.Switch 12 | import Control.Monad.Fix 13 | import Data.List 14 | import Data.Maybe 15 | import Data.Serialize 16 | import GHC.Generics 17 | import Prelude hiding ((.), id) 18 | import System.Console.ANSI 19 | 20 | -- Types 21 | data Cell = Dead | Alive 22 | deriving (Show, Read, Generic) 23 | 24 | type Grid = [[Cell]] 25 | type Neighborhood = [Cell] 26 | 27 | -- make Cell serializable for stateful Autos to work 28 | instance Serialize Cell 29 | 30 | -- Starting grid. A glider, a blinker, a boat, and a beehive. 31 | startingGrid :: Grid 32 | startingGrid = readGrid ["_|_|_|_|_|_|_|_|_|_|_|_|" 33 | ,"_|_|_|_|_|_|_|_|_|_|_|_|" 34 | ,"_|_|_|#|_|_|_|#|#|#|_|_|" 35 | ,"_|_|_|_|#|_|_|_|_|_|_|_|" 36 | ,"_|_|#|#|#|_|_|_|_|_|_|_|" 37 | ,"_|_|_|_|_|_|_|_|_|_|_|_|" 38 | ,"_|_|_|_|_|_|_|_|_|_|_|_|" 39 | ,"_|_|_|_|_|_|_|_|_|#|_|_|" 40 | ,"_|_|#|_|_|_|_|_|#|_|#|_|" 41 | ,"_|#|_|#|_|_|_|_|#|_|#|_|" 42 | ,"_|_|#|#|_|_|_|_|_|#|_|_|" 43 | ,"_|_|_|_|_|_|_|_|_|_|_|_|"] 44 | 45 | main :: IO () 46 | main = loop (board startingGrid) 47 | where 48 | loop a = do 49 | (g, a') <- stepAuto a () 50 | clearScreen 51 | putStrLn (showGrid g) 52 | putStrLn "Press Enter to step simulation." 53 | _ <- getLine 54 | () <$ loop a' 55 | 56 | -- the board Auto; takes an initial configuration and returns an 57 | -- automation. (An Auto ignoring its input and just steppin' along.) 58 | board :: forall m. MonadFix m => Grid -> Auto m () Grid 59 | board g0 = proc _ -> do 60 | -- zipAuto takes a list of Autos and creates a mega Auto that feeds 61 | -- every input into every internal Auto and collects the output. 62 | -- Here we zipAuto Autos representing each Cell...and feed a list 63 | -- containing the neighbors for each cell. Each cell updates 64 | -- according to its neighbors, and the output is the updated list 65 | -- of cells. 66 | -- `neighbors` and `cells` are grids of neighborhoods and 67 | -- cells...so we use `concat` to flatten it out and `chunks c` 68 | -- to re-chunk it back into a grid. 69 | rec cells <- chunks c ^<< dZipAuto nop cells0 <<^ concat -< neighbors 70 | 71 | -- a list of every possible "shift" of `cellGrid` 72 | let shiftedGrids :: [Grid] 73 | shiftedGrids = map ($ cells) allShifts 74 | -- going across each Grid in `shiftedGrids`, and accumulating 75 | -- the cells in every spot. Basically returns a Grid of 76 | -- Neighborhoods, where every spot is associated with 77 | -- a Neighborhood. 78 | neighbors :: [[Neighborhood]] 79 | neighbors = gatherNeighbors shiftedGrids 80 | 81 | id -< cells 82 | where 83 | -- the starting list of Cell Autos, to be zipAuto'd 84 | cells0 :: [Auto m Neighborhood Cell] 85 | cells0 = concatMap (map cell) g0 86 | c = length . head $ g0 87 | -- Various shifting functions to calculate neighborhoods. 88 | shiftU = rotateList 89 | shiftD = reverse . rotateList . reverse 90 | shiftL = map shiftU 91 | shiftR = map shiftD 92 | allShifts = [ shiftU . shiftL , shiftU , shiftU . shiftR 93 | , shiftR , shiftL 94 | , shiftD . shiftL , shiftD , shiftD . shiftR ] 95 | -- Honestly I just found this by typing random things into 96 | -- ghci until I found something that worked. 97 | gatherNeighbors = map transpose . transpose 98 | -- special Neighborhood that keeps a dead cell dead & a live cell live. 99 | -- Used for default Neighborhood in zipAuto. 100 | nop :: Neighborhood 101 | nop = replicate 2 Alive 102 | 103 | -- individual Cell Auto --- give it starting state, and it makes an Auto 104 | -- that takes in a Neighboorhood and returns the next state. 105 | -- switchFromF basically continually runs cell' c0, but every time cell' 106 | -- emits a blip to change its state, restarts cell' with the new state. 107 | cell :: forall m. Monad m => Cell -> Auto m Neighborhood Cell 108 | cell c0 = switchFromF cell' (cell' c0) <<^ length . filter isAlive 109 | where 110 | -- Cell Auto that emits its current state and a Blip signaling a state 111 | -- change. 112 | -- `became` emits a blip every time the predicate becomes true. 113 | -- `tagBlips` replaces the contents with incoming Blips with the 114 | -- given value. (f &&& g) from Control.Arrow "forks" the stream, 115 | -- running `f` through one fork and `g` through the other. 116 | cell' :: Cell -> Auto m Int (Cell, Blip Cell) 117 | cell' Alive = (fromBlips Alive &&& id) . tagBlips Dead . became death -- Oppenheimer 118 | cell' Dead = (fromBlips Dead &&& id) . tagBlips Alive . became spawn 119 | 120 | -- predicates for swapping 121 | death, spawn :: Int -> Bool 122 | death = liftA2 (||) (< 2) (> 3) 123 | spawn = (== 3) 124 | 125 | -- utility 126 | isAlive :: Cell -> Bool 127 | isAlive Alive = True 128 | isAlive Dead = False 129 | 130 | showGrid :: Grid -> String 131 | showGrid = unlines . map (concatMap showCell) 132 | where 133 | showCell Alive = "#|" 134 | showCell Dead = "_|" 135 | 136 | readGrid :: [String] -> Grid 137 | readGrid = (map . mapMaybe) readCell 138 | where 139 | readCell '|' = Nothing 140 | readCell '_' = Just Dead 141 | readCell _ = Just Alive 142 | 143 | -- rotateList: [1,2,3,4] -> [2,3,4,1] 144 | rotateList :: [a] -> [a] 145 | rotateList = uncurry (flip (++)) . splitAt 1 146 | 147 | -- chunks up items in a list in groups of n. 148 | -- chunks 2 [1,2,3,4,5] -> [[1,2],[3,4],[5]] 149 | chunks :: Int -> [a] -> [[a]] 150 | chunks n = takeWhile (not.null) . unfoldr (Just . splitAt n) 151 | 152 | -------------------------------------------------------------------------------- /auto-examples.cabal: -------------------------------------------------------------------------------- 1 | -- Initial auto-examples.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: auto-examples 5 | version: 0.1.0.0 6 | synopsis: Examples for applications written using the auto library 7 | -- description: 8 | license: MIT 9 | license-file: LICENSE 10 | author: Justin Le 11 | maintainer: justin@jle.im 12 | -- copyright: 13 | category: Game 14 | build-type: Simple 15 | extra-source-files: assets/todo/base.css 16 | , assets/todo/style.css 17 | cabal-version: >=1.10 18 | 19 | executable hangman 20 | main-is: Hangman.hs 21 | hs-source-dirs: src 22 | -- other-modules: 23 | -- other-extensions: 24 | build-depends: base >=4.7 && <5 25 | , auto 26 | , random 27 | , transformers 28 | , MonadRandom 29 | , cereal 30 | hs-source-dirs: src 31 | ghc-options: -O2 -Wall 32 | default-language: Haskell2010 33 | 34 | executable logger 35 | main-is: Logger.hs 36 | hs-source-dirs: src 37 | -- other-modules: 38 | -- other-extensions: 39 | build-depends: base >=4.7 && <5 40 | , auto 41 | , old-locale 42 | , time 43 | , transformers 44 | hs-source-dirs: src 45 | ghc-options: -O2 -Wall 46 | default-language: Haskell2010 47 | 48 | executable chatbot 49 | main-is: Chatbot.hs 50 | hs-source-dirs: src 51 | -- other-modules: 52 | -- other-extensions: 53 | build-depends: base >=4.7 && <5 54 | , auto 55 | , bytestring 56 | , cereal 57 | , containers 58 | , simpleirc 59 | , time 60 | , transformers 61 | hs-source-dirs: src 62 | ghc-options: -O2 -Wall 63 | default-language: Haskell2010 64 | 65 | executable life 66 | main-is: Life.hs 67 | hs-source-dirs: src 68 | -- other-modules: 69 | -- other-extensions: 70 | build-depends: base >=4.7 && <5 71 | , ansi-terminal 72 | , auto 73 | , cereal 74 | hs-source-dirs: src 75 | ghc-options: -O2 -Wall 76 | default-language: Haskell2010 77 | 78 | -- executable life-gui 79 | -- main-is: LifeGUI.hs 80 | -- hs-source-dirs: src 81 | -- -- other-modules: 82 | -- -- other-extensions: 83 | -- build-depends: base >=4.7 && <5 84 | -- , auto 85 | -- , cereal 86 | -- , gloss 87 | -- hs-source-dirs: src 88 | -- default-language: Haskell2010 89 | 90 | executable connect4 91 | main-is: Connect4.hs 92 | hs-source-dirs: src/Experimental/ 93 | -- other-modules: 94 | -- other-extensions: 95 | build-depends: base >=4.7 && <5 96 | , ansi-terminal 97 | , auto 98 | , cereal 99 | , containers 100 | , transformers 101 | , random 102 | hs-source-dirs: src 103 | ghc-options: -O2 -Wall 104 | default-language: Haskell2010 105 | 106 | executable mhmc 107 | main-is: MHMC.hs 108 | hs-source-dirs: src 109 | -- other-modules: 110 | -- other-extensions: 111 | build-depends: base >=4.7 && <5 112 | , auto 113 | , random 114 | , transformers 115 | , repa 116 | hs-source-dirs: src 117 | ghc-options: -O2 -threaded -Wall 118 | default-language: Haskell2010 119 | 120 | executable neural 121 | main-is: Neural.hs 122 | hs-source-dirs: src/Experimental/ 123 | -- other-modules: 124 | -- other-extensions: 125 | build-depends: base >=4.7 && <5 126 | , auto 127 | , cereal 128 | , profunctors 129 | , random 130 | , linear 131 | hs-source-dirs: src 132 | ghc-options: -O2 -Wall 133 | default-language: Haskell2010 134 | 135 | executable survive 136 | main-is: Survive.hs 137 | hs-source-dirs: src/Experimental/ 138 | -- other-modules: 139 | -- other-extensions: 140 | build-depends: base >=4.7 && <5 141 | , auto 142 | , random 143 | , ansi-terminal 144 | , transformers 145 | , mtl 146 | , containers 147 | , cereal 148 | , lens 149 | , linear 150 | , profunctors 151 | , MonadRandom 152 | , containers 153 | hs-source-dirs: src 154 | ghc-options: -O2 -Wall 155 | default-language: Haskell2010 156 | 157 | -- executable adventure 158 | -- main-is: Adventure.hs 159 | -- hs-source-dirs: src 160 | -- -- other-modules: 161 | -- -- other-extensions: 162 | -- build-depends: base >=4.7 && <5 163 | -- , auto 164 | -- , random 165 | -- , transformers 166 | -- , containers 167 | -- hs-source-dirs: src 168 | -- ghc-options: -O2 -Wall 169 | -- default-language: Haskell2010 170 | 171 | executable recursive 172 | main-is: Recursive.hs 173 | hs-source-dirs: src/Experimental/ 174 | -- other-modules: 175 | -- other-extensions: 176 | build-depends: base >=4.7 && <5 177 | , auto 178 | hs-source-dirs: src 179 | ghc-options: -O2 -Wall 180 | default-language: Haskell2010 181 | 182 | executable todo 183 | main-is: TodoCmd.hs 184 | hs-source-dirs: src 185 | -- other-modules: 186 | -- other-extensions: 187 | build-depends: base >=4.7 && <5 188 | , auto 189 | , containers 190 | , cereal 191 | , profunctors 192 | hs-source-dirs: src 193 | ghc-options: -O2 -Wall 194 | default-language: Haskell2010 195 | 196 | executable todo-js 197 | main-is: TodoJS.hs 198 | hs-source-dirs: src 199 | -- other-modules: 200 | -- other-extensions: 201 | if impl(ghcjs) 202 | build-depends: base >=4.7 && <5 203 | , auto 204 | , containers 205 | , cereal 206 | , ghcjs-base 207 | , ghcjs-dom 208 | , transformers 209 | , profunctors 210 | hs-source-dirs: src 211 | ghc-options: -O2 -Wall 212 | default-language: Haskell2010 213 | if impl(ghcjs) 214 | buildable: True 215 | else 216 | buildable: False 217 | 218 | executable rps 219 | main-is: RPSCmd.hs 220 | hs-source-dirs: src 221 | -- other-modules: 222 | -- other-extensions: 223 | build-depends: base >=4.7 && <5 224 | , auto >=0.4.2 225 | , containers 226 | , cereal 227 | , profunctors 228 | , network-simple 229 | hs-source-dirs: src 230 | ghc-options: -O2 -Wall 231 | default-language: Haskell2010 232 | 233 | -------------------------------------------------------------------------------- /assets/todo/index.css: -------------------------------------------------------------------------------- 1 | html, 2 | body { 3 | margin: 0; 4 | padding: 0; 5 | } 6 | 7 | button { 8 | margin: 0; 9 | padding: 0; 10 | border: 0; 11 | background: none; 12 | font-size: 100%; 13 | vertical-align: baseline; 14 | font-family: inherit; 15 | font-weight: inherit; 16 | color: inherit; 17 | -webkit-appearance: none; 18 | -ms-appearance: none; 19 | appearance: none; 20 | -webkit-font-smoothing: antialiased; 21 | -moz-font-smoothing: antialiased; 22 | -ms-font-smoothing: antialiased; 23 | font-smoothing: antialiased; 24 | } 25 | 26 | body { 27 | font: 14px 'Helvetica Neue', Helvetica, Arial, sans-serif; 28 | line-height: 1.4em; 29 | background: #f5f5f5; 30 | color: #4d4d4d; 31 | min-width: 230px; 32 | max-width: 550px; 33 | margin: 0 auto; 34 | -webkit-font-smoothing: antialiased; 35 | -moz-font-smoothing: antialiased; 36 | -ms-font-smoothing: antialiased; 37 | font-smoothing: antialiased; 38 | font-weight: 300; 39 | } 40 | 41 | button, 42 | input[type="checkbox"] { 43 | outline: none; 44 | } 45 | 46 | .hidden { 47 | display: none; 48 | } 49 | 50 | #todoapp { 51 | background: #fff; 52 | margin: 130px 0 40px 0; 53 | position: relative; 54 | box-shadow: 0 2px 4px 0 rgba(0, 0, 0, 0.2), 55 | 0 25px 50px 0 rgba(0, 0, 0, 0.1); 56 | } 57 | 58 | #todoapp input::-webkit-input-placeholder { 59 | font-style: italic; 60 | font-weight: 300; 61 | color: #e6e6e6; 62 | } 63 | 64 | #todoapp input::-moz-placeholder { 65 | font-style: italic; 66 | font-weight: 300; 67 | color: #e6e6e6; 68 | } 69 | 70 | #todoapp input::input-placeholder { 71 | font-style: italic; 72 | font-weight: 300; 73 | color: #e6e6e6; 74 | } 75 | 76 | #todoapp h1 { 77 | position: absolute; 78 | top: -155px; 79 | width: 100%; 80 | font-size: 100px; 81 | font-weight: 100; 82 | text-align: center; 83 | color: rgba(175, 47, 47, 0.15); 84 | -webkit-text-rendering: optimizeLegibility; 85 | -moz-text-rendering: optimizeLegibility; 86 | -ms-text-rendering: optimizeLegibility; 87 | text-rendering: optimizeLegibility; 88 | } 89 | 90 | #new-todo, 91 | .edit { 92 | position: relative; 93 | margin: 0; 94 | width: 100%; 95 | font-size: 24px; 96 | font-family: inherit; 97 | font-weight: inherit; 98 | line-height: 1.4em; 99 | border: 0; 100 | outline: none; 101 | color: inherit; 102 | padding: 6px; 103 | border: 1px solid #999; 104 | box-shadow: inset 0 -1px 5px 0 rgba(0, 0, 0, 0.2); 105 | -ms-box-sizing: border-box; 106 | box-sizing: border-box; 107 | -webkit-font-smoothing: antialiased; 108 | -moz-font-smoothing: antialiased; 109 | -ms-font-smoothing: antialiased; 110 | font-smoothing: antialiased; 111 | } 112 | 113 | #new-todo { 114 | padding: 16px 16px 16px 60px; 115 | border: none; 116 | background: rgba(0, 0, 0, 0.003); 117 | box-shadow: inset 0 -2px 1px rgba(0,0,0,0.03); 118 | } 119 | 120 | #main { 121 | position: relative; 122 | z-index: 2; 123 | border-top: 1px solid #e6e6e6; 124 | } 125 | 126 | label[for='toggle-all'] { 127 | display: none; 128 | } 129 | 130 | #toggle-all { 131 | position: absolute; 132 | top: -55px; 133 | left: -12px; 134 | width: 60px; 135 | height: 34px; 136 | text-align: center; 137 | border: none; /* Mobile Safari */ 138 | } 139 | 140 | #toggle-all:before { 141 | content: '❯'; 142 | font-size: 22px; 143 | color: #e6e6e6; 144 | padding: 10px 27px 10px 27px; 145 | } 146 | 147 | #toggle-all:checked:before { 148 | color: #737373; 149 | } 150 | 151 | #todo-list { 152 | margin: 0; 153 | padding: 0; 154 | list-style: none; 155 | } 156 | 157 | #todo-list li { 158 | position: relative; 159 | font-size: 24px; 160 | border-bottom: 1px solid #ededed; 161 | } 162 | 163 | #todo-list li:last-child { 164 | border-bottom: none; 165 | } 166 | 167 | #todo-list li.editing { 168 | border-bottom: none; 169 | padding: 0; 170 | } 171 | 172 | #todo-list li.editing .edit { 173 | display: block; 174 | width: 506px; 175 | padding: 13px 17px 12px 17px; 176 | margin: 0 0 0 43px; 177 | } 178 | 179 | #todo-list li.editing .view { 180 | display: none; 181 | } 182 | 183 | #todo-list li .toggle { 184 | text-align: center; 185 | width: 40px; 186 | /* auto, since non-WebKit browsers doesn't support input styling */ 187 | height: auto; 188 | position: absolute; 189 | top: 0; 190 | bottom: 0; 191 | margin: auto 0; 192 | border: none; /* Mobile Safari */ 193 | -webkit-appearance: none; 194 | -ms-appearance: none; 195 | appearance: none; 196 | } 197 | 198 | #todo-list li .toggle:after { 199 | content: url('data:image/svg+xml;utf8,'); 200 | } 201 | 202 | #todo-list li .toggle:checked:after { 203 | content: url('data:image/svg+xml;utf8,'); 204 | } 205 | 206 | #todo-list li label { 207 | white-space: pre; 208 | word-break: break-word; 209 | padding: 15px 60px 15px 15px; 210 | margin-left: 45px; 211 | display: block; 212 | line-height: 1.2; 213 | transition: color 0.4s; 214 | } 215 | 216 | #todo-list li.completed label { 217 | color: #d9d9d9; 218 | text-decoration: line-through; 219 | } 220 | 221 | #todo-list li .destroy { 222 | display: none; 223 | position: absolute; 224 | top: 0; 225 | right: 10px; 226 | bottom: 0; 227 | width: 40px; 228 | height: 40px; 229 | margin: auto 0; 230 | font-size: 30px; 231 | color: #cc9a9a; 232 | margin-bottom: 11px; 233 | transition: color 0.2s ease-out; 234 | } 235 | 236 | #todo-list li .destroy:hover { 237 | color: #af5b5e; 238 | } 239 | 240 | #todo-list li .destroy:after { 241 | content: '×'; 242 | } 243 | 244 | #todo-list li:hover .destroy { 245 | display: block; 246 | } 247 | 248 | #todo-list li .edit { 249 | display: none; 250 | } 251 | 252 | #todo-list li.editing:last-child { 253 | margin-bottom: -1px; 254 | } 255 | 256 | #footer { 257 | color: #777; 258 | padding: 10px 15px; 259 | height: 20px; 260 | text-align: center; 261 | border-top: 1px solid #e6e6e6; 262 | } 263 | 264 | #footer:before { 265 | content: ''; 266 | position: absolute; 267 | right: 0; 268 | bottom: 0; 269 | left: 0; 270 | height: 50px; 271 | overflow: hidden; 272 | box-shadow: 0 1px 1px rgba(0, 0, 0, 0.2), 273 | 0 8px 0 -3px #f6f6f6, 274 | 0 9px 1px -3px rgba(0, 0, 0, 0.2), 275 | 0 16px 0 -6px #f6f6f6, 276 | 0 17px 2px -6px rgba(0, 0, 0, 0.2); 277 | } 278 | 279 | #todo-count { 280 | float: left; 281 | text-align: left; 282 | } 283 | 284 | #todo-count strong { 285 | font-weight: 300; 286 | } 287 | 288 | #filters { 289 | margin: 0; 290 | padding: 0; 291 | list-style: none; 292 | position: absolute; 293 | right: 0; 294 | left: 0; 295 | } 296 | 297 | #filters li { 298 | display: inline; 299 | } 300 | 301 | #filters li a { 302 | color: inherit; 303 | margin: 3px; 304 | padding: 3px 7px; 305 | text-decoration: none; 306 | border: 1px solid transparent; 307 | border-radius: 3px; 308 | } 309 | 310 | #filters li a.selected, 311 | #filters li a:hover { 312 | border-color: rgba(175, 47, 47, 0.1); 313 | } 314 | 315 | #filters li a.selected { 316 | border-color: rgba(175, 47, 47, 0.2); 317 | } 318 | 319 | #clear-completed, 320 | html #clear-completed:active { 321 | float: right; 322 | position: relative; 323 | line-height: 20px; 324 | text-decoration: none; 325 | cursor: pointer; 326 | visibility: hidden; 327 | position: relative; 328 | } 329 | 330 | #clear-completed::after { 331 | visibility: visible; 332 | content: 'Clear completed'; 333 | position: absolute; 334 | right: 0; 335 | white-space: nowrap; 336 | } 337 | 338 | #clear-completed:hover::after { 339 | text-decoration: underline; 340 | } 341 | 342 | #info { 343 | margin: 65px auto 0; 344 | color: #bfbfbf; 345 | font-size: 10px; 346 | text-shadow: 0 1px 0 rgba(255, 255, 255, 0.5); 347 | text-align: center; 348 | } 349 | 350 | #info p { 351 | line-height: 1; 352 | } 353 | 354 | #info a { 355 | color: inherit; 356 | text-decoration: none; 357 | font-weight: 400; 358 | } 359 | 360 | #info a:hover { 361 | text-decoration: underline; 362 | } 363 | 364 | /* 365 | Hack to remove background from Mobile Safari. 366 | Can't use it globally since it destroys checkboxes in Firefox 367 | */ 368 | @media screen and (-webkit-min-device-pixel-ratio:0) { 369 | #toggle-all, 370 | #todo-list li .toggle { 371 | background: none; 372 | } 373 | 374 | #todo-list li .toggle { 375 | height: 40px; 376 | } 377 | 378 | #toggle-all { 379 | -webkit-transform: rotate(90deg); 380 | transform: rotate(90deg); 381 | -webkit-appearance: none; 382 | appearance: none; 383 | } 384 | } 385 | 386 | @media (max-width: 430px) { 387 | #footer { 388 | height: 50px; 389 | } 390 | 391 | #filters { 392 | bottom: 10px; 393 | } 394 | } 395 | -------------------------------------------------------------------------------- /src/Compact/Hangman.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE Arrows #-} 3 | 4 | module Main (main) where 5 | 6 | import Control.Auto 7 | import Control.Auto.Blip 8 | import Control.Auto.Process.Random 9 | import Control.Auto.Run 10 | import Data.Functor.Identity 11 | import Control.Auto.Serialize 12 | import Control.Exception hiding (mask) 13 | import Data.Foldable (mapM_) 14 | import Control.Auto.Switch 15 | import Control.Monad hiding (mapM_) 16 | import Data.Char 17 | import Data.List 18 | import Data.Maybe 19 | import Prelude hiding ((.), id, mapM_) 20 | import System.Random 21 | 22 | {-# ANN Puzzle "HLint: ignore Use String" #-} 23 | {-# ANN game "HLint: ignore Use string literal" #-} 24 | 25 | data GCommand = Help 26 | | Quit 27 | | HM HMCommand 28 | deriving Show 29 | 30 | data HMCommand = Guess Char 31 | | Solve String 32 | | New 33 | | Display 34 | deriving Show 35 | 36 | data Puzzle = Puzzle { puzzleString :: String -- The "masked" string 37 | , puzzleWrongs :: [Char] -- List of wrong guesses 38 | , puzzleStatus :: Status 39 | } deriving Show 40 | 41 | data Status = InProgress 42 | | Success String 43 | | Failure String 44 | deriving Show 45 | 46 | data PuzzleOut = Puzz Puzzle Bool -- return current puzzle; show score? 47 | | Swap Puzzle Puzzle -- old puzzle, new puzzle 48 | deriving Show 49 | 50 | wordlistFP :: FilePath 51 | wordlistFP = "data/wordlist.txt" 52 | 53 | savegameFP :: FilePath 54 | savegameFP = "data/save/hangman" 55 | 56 | guesses :: Int 57 | guesses = 7 58 | 59 | helpmsg :: String 60 | helpmsg = unlines [ "Solve the hangman!" 61 | , "> @new : new game " 62 | , "> @help : display this message " 63 | , "> @display : display score and puzzle" 64 | , "> (any single character) : guess that character " 65 | , "> @solve [sol] : attempt to solve " 66 | , "> @quit : quit " 67 | ] 68 | 69 | main :: IO () 70 | main = do 71 | putStrLn "Welcome to Hangman! Type @help for help!" 72 | wordlist <- lines . map toLower <$> readFile wordlistFP 73 | g <- getStdGen 74 | let gameAuto = hangman wordlist g :: Auto Identity String (Maybe String) 75 | loaded <- try (readAuto savegameFP gameAuto) 76 | loadedGame <- case loaded of 77 | Right (Right a) -> do 78 | putStrLn "Save file found! Restoring game." 79 | return a 80 | Left (_ :: SomeException) -> do 81 | putStrLn "No save file found; creating new game." 82 | return gameAuto 83 | _ -> do 84 | putStrLn "Save file corrupted; creating new game." 85 | return gameAuto 86 | let (str, initGame) = stepAuto' loadedGame "@display" 87 | mapM_ putStrLn str 88 | finalGame <- interactId initGame 89 | putStrLn $ "Saving game to " <> savegameFP <> "..." 90 | writeAuto savegameFP finalGame 91 | putStrLn "Goodbye!" 92 | 93 | hangman :: Monad m 94 | => [String] -- ^ Word list 95 | -> StdGen -- ^ Random seed 96 | -> Auto m String (Maybe String) 97 | hangman wordlist g = proc inp -> do 98 | let comm = case words inp of 99 | "@help" : _ -> Just Help 100 | "@quit" : _ -> Just Quit 101 | "@display": _ -> Just (HM Display) 102 | "@solve" : ws -> Just . HM . Solve 103 | . map toLower $ unwords ws 104 | "@new" : _ -> Just (HM New) 105 | [[c]] | isAlpha c -> Just . HM . Guess $ toLower c 106 | _ -> Nothing 107 | 108 | case comm of 109 | Nothing -> id -< return "Unknown command. @help for help." 110 | Just Help -> id -< return helpmsg 111 | Just Quit -> id -< mzero 112 | Just (HM hcomm) -> do 113 | newstr <- stdRands (pick wordlist) g -< () 114 | puzz <- switchFromF game initialize -< (hcomm, newstr) 115 | swaps <- emitOn isSwap -< puzz 116 | losses <- countB . filterB isFailure -< swaps 117 | wins <- countB . filterB isSuccess -< swaps 118 | id -< return $ case puzz of 119 | -- just the puzzle 120 | Puzz p False -> display p 121 | -- puzzle + score 122 | Puzz p True -> displayScore (wins, losses) 123 | <> "\n" 124 | <> display p 125 | -- the old puzzle and a new puzzle 126 | Swap p0 p1 -> display p0 127 | <> "\n" 128 | <> displayScore (wins, losses) 129 | <> "\n" 130 | <> display p1 131 | 132 | initialize :: Monad m 133 | => Auto m (HMCommand, String) (PuzzleOut, Blip String) 134 | initialize = proc (_, newstr) -> do 135 | new <- immediately -< newstr 136 | id -< (Puzz (blankPuzzle newstr) True, new) 137 | 138 | game :: Monad m 139 | => String -- ^ The mystery word(s) 140 | -> Auto m (HMCommand, String) (PuzzleOut, Blip String) 141 | game str = proc (comm, newstr) -> do 142 | let (corr, incorr, solve) = case comm of 143 | Guess c | c `elem` str -> (Just c , Nothing , False) 144 | | otherwise -> (Nothing, Just c , False) 145 | Solve s | s == str -> (Nothing, Nothing , True ) 146 | | otherwise -> (Nothing, Just '*', False) 147 | _ -> (Nothing, Nothing , False) 148 | rights <- accum (++) [' '] -< maybeToList corr 149 | wrongs <- reverse <$> accum add [] -< incorr 150 | let solved = solve || all (`elem` rights) str 151 | failed = length wrongs > guesses 152 | status | solved = Success str 153 | | failed = Failure str 154 | | otherwise = InProgress 155 | puzz = Puzzle { puzzleString = map (mask rights) str 156 | , puzzleWrongs = wrongs 157 | , puzzleStatus = status 158 | } 159 | mkNew = case comm of 160 | New -> Just (puzz { puzzleStatus = Failure str }) 161 | _ | solved || failed -> Just puzz 162 | | otherwise -> Nothing 163 | case mkNew of 164 | Just p' -> do 165 | let newPuzz = blankPuzzle newstr 166 | new <- immediately -< newstr 167 | id -< (Swap p' newPuzz, new) 168 | Nothing -> do 169 | let showScore = isDisplay comm 170 | new <- never -< () 171 | id -< (Puzz puzz showScore, new) 172 | where 173 | add ws w = case w of 174 | Just '*' -> '*':ws 175 | Just c | c `notElem` ws -> c :ws 176 | _ -> ws 177 | 178 | pick :: [a] -> StdGen -> (a, StdGen) 179 | pick [] _ = error "pick: Cannot pick from empty list." 180 | pick xs g = (xs !! n, g') 181 | where 182 | (n, g') = randomR (0, length xs - 1) g 183 | 184 | blankPuzzle :: String -> Puzzle 185 | blankPuzzle str = Puzzle (map (mask []) str) [] InProgress 186 | 187 | mask :: String -> Char -> Char 188 | mask _ ' ' = ' ' 189 | mask rs c | c `elem` rs = c 190 | | otherwise = '_' 191 | 192 | display :: Puzzle -> String 193 | display (Puzzle str ws sts) = pre 194 | <> " [" <> str' <> "] " 195 | <> "(" <> ws 196 | <> replicate (guesses + 1 - length ws) '.' 197 | <> ")" 198 | where 199 | (pre, str') = case sts of 200 | InProgress -> ("Active:", str) 201 | Success s -> ("Solved!", s ) 202 | Failure s -> ("Failed!", s ) 203 | 204 | displayScore :: (Int, Int) -> String 205 | displayScore (w, l) = unwords ["Wins:", show w, "|", "Losses:", show l] 206 | 207 | isSwap :: PuzzleOut -> Bool 208 | isSwap (Swap _ _) = True 209 | isSwap _ = False 210 | 211 | isFailure :: PuzzleOut -> Bool 212 | isFailure (Swap (Puzzle _ _ (Failure _)) _) = True 213 | isFailure _ = False 214 | 215 | isSuccess :: PuzzleOut -> Bool 216 | isSuccess (Swap (Puzzle _ _ (Success _)) _) = True 217 | isSuccess _ = False 218 | 219 | isDisplay :: HMCommand -> Bool 220 | isDisplay Display = True 221 | isDisplay _ = False 222 | -------------------------------------------------------------------------------- /src/Chatbot.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE Arrows #-} 3 | {-# LANGUAGE TupleSections #-} 4 | {-# OPTIONS -fno-warn-orphans #-} 5 | 6 | module Main (main) where 7 | 8 | import Control.Auto 9 | import Control.Auto.Blip 10 | import Control.Auto.Serialize 11 | import Control.Auto.Switch 12 | import Control.Concurrent 13 | import Control.Exception 14 | import Control.Monad 15 | import Control.Monad.IO.Class 16 | import Data.Map.Strict (Map) 17 | import Data.Serialize 18 | import Data.Time 19 | import Network.SimpleIRC 20 | import Prelude hiding ((.), id) 21 | import qualified Data.ByteString.Char8 as C8 22 | import qualified Data.Map.Strict as M 23 | 24 | -- | Types 25 | 26 | -- A Chat bot; takes in a message and outputs a map of (Channel, Messages) 27 | -- pairs 28 | type ChatBot m = Auto m InMessage OutMessages 29 | -- A simplified chat bot which only outputs messages to the channel it 30 | -- received the incoming message from 31 | type ChatBot' m = Auto m InMessage (Blip [Message]) 32 | 33 | type Nick = String 34 | type Channel = String 35 | type Message = String 36 | 37 | data InMessage = InMessage { _inMessageNick :: Nick 38 | , _inMessageBody :: Message 39 | , _inMessageSource :: Channel 40 | , _inMessageTime :: UTCTime 41 | } deriving Show 42 | 43 | -- Output map; the keys are channels and the values are messages to send to 44 | -- each channel. 45 | data OutMessages = OutMessages (Map Channel [Message]) 46 | 47 | instance Monoid OutMessages where 48 | mempty = OutMessages M.empty 49 | mappend (OutMessages m1) (OutMessages m2) 50 | = OutMessages (M.unionWith (++) m1 m2) 51 | 52 | 53 | -- config 54 | botName :: Nick 55 | botName = "autobot-test" 56 | 57 | channels :: [Channel] 58 | channels = ["#autobot-test"] 59 | 60 | chatbotFP :: FilePath 61 | chatbotFP = "data/save/chatbot" 62 | 63 | -- main 64 | main :: IO () 65 | main = launchIRC chatBot 66 | 67 | -- The bot! Basically a monoid sum of smaller bots. Note that each 68 | -- component bot is selectively serialized. 69 | chatBot :: ChatBot IO 70 | chatBot = mconcat [ s "seen" $ perRoom seenBot -- seenBot, self-serializing 71 | , perRoom karmaBot 72 | , s "ann" announceBot 73 | ] 74 | where 75 | -- transforms an Auto into a self-serializing and self-reloading Auto, 76 | -- saving at that given filepath. 77 | s fp = serializing' (chatbotFP ++ "-" ++ fp) 78 | 79 | -- Helper function to transform a Chatbot' into a Chatbot --- chatbots 80 | -- written for single-channel intput/output to multi-channel-aware 81 | -- input/output. 82 | perRoom :: Monad m => ChatBot' m -> ChatBot m 83 | perRoom cb' = proc im -> do 84 | outs <- fromBlips [] . cb' -< im 85 | id -< OutMessages $ M.singleton (_inMessageSource im) outs 86 | 87 | -- | The Modules/bots 88 | 89 | -- seenBot: Maintains a map of nicks and their last received message. On 90 | -- the command '@seen [nick]', looks up that nick and reports the last 91 | -- seen time. 92 | seenBot :: Monad m => ChatBot' m 93 | seenBot = proc (InMessage nick msg _ time) -> do 94 | -- seens :: Map Nick UTCTime 95 | -- Map containing last time each nick has spoken. Uses `accum` and the 96 | -- helper function `addToMap` to update the Map on every message. 97 | seens <- accum addToMap M.empty -< (nick, time) 98 | 99 | -- query :: Blip Nick 100 | -- blip stream emits whenever someone queries for a last time seen; 101 | -- emits with the nick queried for 102 | query <- emitJusts getRequest -< words msg 103 | 104 | -- a function to get a response from a nick query 105 | let respond :: Nick -> [Message] 106 | respond qry = case M.lookup qry seens of 107 | Just t -> [qry ++ " last seen at " ++ show t ++ "."] 108 | Nothing -> ["No record of " ++ qry ++ "."] 109 | 110 | -- output is, whenever the `query` stream emits, map `respond` to it. 111 | id -< respond <$> query 112 | where 113 | addToMap :: Map Nick UTCTime -> (Nick, UTCTime) -> Map Nick UTCTime 114 | addToMap mp (nick, time) = M.insert nick time mp 115 | getRequest ("@seen":request:_) = Just request 116 | getRequest _ = Nothing 117 | 118 | -- karmaBot: Maintains a map of nicks and associated "karma", imaginary 119 | -- internet points. --- users can increase a nick's karma by saying 120 | -- `@addKarma [nick]`...can subtract by saying `@subKarma [nick]`...or 121 | -- just query the map by saying `@karma [nick]`. In all cases, the 122 | -- current karma is reported. 123 | karmaBot :: Monad m => ChatBot' m 124 | karmaBot = proc (InMessage _ msg _ _) -> do 125 | -- karmaBlip :: Blip (Nick, Int) 126 | -- blip stream emits when someone modifies karma, with nick and increment 127 | karmaBlip <- emitJusts getComm -< msg 128 | 129 | -- karmas :: Map Nick Int 130 | -- keeps track of the total karma for each user by updating with karmaBlip 131 | karmas <- scanB updateMap M.empty -< karmaBlip 132 | 133 | -- function to look up a nick, if one is asked for 134 | let lookupKarma :: Nick -> [Message] 135 | lookupKarma nick = let karm = M.findWithDefault 0 nick karmas 136 | in [nick ++ " has a karma of " ++ show karm ++ "."] 137 | 138 | -- output is, whenever `karmaBlip` stream emits, look up the result 139 | id -< lookupKarma . fst <$> karmaBlip 140 | where 141 | getComm :: String -> Maybe (Nick, Int) 142 | getComm msg = case words msg of 143 | "@addKarma":nick:_ -> Just (nick, 1 ) 144 | "@subKarma":nick:_ -> Just (nick, -1) 145 | "@karma":nick:_ -> Just (nick, 0) 146 | _ -> Nothing 147 | updateMap :: Map Nick Int -> (Nick, Int) -> Map Nick Int 148 | updateMap mp (nick, change) = M.insertWith (+) nick change mp 149 | 150 | -- announceBot: Listen on all channels (including private messages) for 151 | -- announcements of the form `@ann [message]`; when received, broadcast 152 | -- the message to all channels the bot is in. However, rate-limit the 153 | -- broadcasts and only allow 3 announcements per day per user, reset 154 | -- every day at midnight. 155 | announceBot :: forall m. Monad m => ChatBot m 156 | announceBot = proc (InMessage nick msg src time) -> do 157 | -- annBlip :: Blip [Message] 158 | -- blip stream emits when someone wants an echo, with the message 159 | annBlip <- emitJusts getAnnounce -< (nick, msg) 160 | 161 | -- newDayBlip :: Blip UTCTime 162 | -- blip stream emits whenever the day changes 163 | newDayBlip <- onChange -< utctDay time 164 | 165 | -- annCounts :: Map Nick Int 166 | -- `countEchos` counts the number of times each user asks for an echo, and 167 | -- `resetOn` makes it "reset" itself whenever `newDayBlip` emits. 168 | annCounts <- resetOn countAnns -< (nick <$ annBlip, newDayBlip) 169 | 170 | -- has this user flooded today...? 171 | let hasFlooded = M.lookup nick annCounts > Just floodLimit 172 | -- toRooms :: Blip [Message] 173 | -- blip stream emits whenever someone asks for an echo, limiting flood 174 | outMsg | hasFlooded = ["No flooding!"] <$ annBlip 175 | | otherwise = annBlip 176 | -- targets :: [Channel] 177 | -- the rooms to announce to. if flooded, only echo back to source. 178 | targets | hasFlooded = [src] 179 | | otherwise = channels 180 | 181 | -- outputs :: Blip (Map Channel [Message]) 182 | -- blip stream that emits a map of messages to send to each 183 | -- channel. 184 | outputs = M.fromList . zip targets . repeat <$> outMsg 185 | 186 | -- when 'outputs' is not emitting, just pop out an empty 'OutMessages'. 187 | -- Otherwise, make one from the 'Map' that was emitted. 188 | fromBlipsWith mempty OutMessages -< outputs 189 | where 190 | getAnnounce :: (Nick, Message) -> Maybe [Message] 191 | getAnnounce (nick, msg) = 192 | case words msg of 193 | "@ann":ann -> Just [nick ++ " says \"" ++ unwords ann ++ "\"."] 194 | _ -> Nothing 195 | floodLimit = 5 196 | isEcho msg = case words msg of 197 | "@echo":xs -> Just [unwords xs] 198 | _ -> Nothing 199 | countAnns :: Auto m (Blip Nick) (Map Nick Int) 200 | countAnns = scanB countingFunction M.empty 201 | countingFunction :: Map Nick Int -> Nick -> Map Nick Int 202 | countingFunction mp nick = M.insertWith (+) nick 1 mp 203 | 204 | -- | Serialize instances for the time types. 205 | instance Serialize UTCTime where 206 | get = read <$> get -- haha don't do this in real life. 207 | put = put . show 208 | 209 | instance Serialize Day where 210 | get = ModifiedJulianDay <$> get 211 | put = put . toModifiedJulianDay 212 | 213 | -- | Boring low-level MIRC stuff; mostly stuff from the simpleirc library. 214 | -- Don't worry about this too much :) For more information, read the 215 | -- simpleirc documentation. 216 | 217 | -- ircConf: IRC configuration for simpleirc. Specifies server, name, 218 | -- channels, and the Privmsg handler. 219 | ircConf :: MVar (ChatBot IO) -> IrcConfig 220 | ircConf a = (mkDefaultConfig "irc.freenode.org" botName) 221 | { cChannels = channels 222 | , cEvents = [Privmsg (onMessage a)] 223 | } 224 | 225 | -- begin the IRC process with stdout logging. 226 | launchIRC :: ChatBot IO -> IO () 227 | launchIRC a0 = do 228 | amvr <- newMVar a0 229 | let launch = connect (ircConf amvr) False True 230 | void launch `catch` \(_ :: AsyncException) -> return () 231 | 232 | -- onMessage: the Privmsg handler. On every Privmsg, pull the Auto out of 233 | -- the MVar, step it to get the results, and put the modified Auto back 234 | -- into the MVar. Check out the documentation for simpleirc and 235 | -- `Control.Concurrent` for more information. 236 | onMessage :: MVar (ChatBot IO) -> EventFunc 237 | onMessage amvr server msg = do 238 | OutMessages resps <- modifyMVar amvr $ \a -> 239 | case (mNick msg, mOrigin msg) of 240 | (Just nick, Just orig) -> do 241 | t <- getCurrentTime 242 | let inmsg = InMessage (C8.unpack nick) (C8.unpack (mMsg msg)) 243 | (C8.unpack orig) t 244 | (out, a') <- stepAuto a inmsg 245 | return (a', out ) 246 | _ -> 247 | return (a , mempty) 248 | _ <- flip M.traverseWithKey resps $ \k v -> 249 | mapM_ (sendMsg server (C8.pack k) . C8.pack) v 250 | return () 251 | 252 | -------------------------------------------------------------------------------- /src/Hangman.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE Arrows #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE TupleSections #-} 5 | 6 | -- | "Hangman" 7 | -- 8 | -- A fully featured command-line hangman game. Made to demonstrate many 9 | -- high-level features, like the composition of locally stateful autos with 10 | -- proc-do notation, implicit serializability, switching, and usage of 11 | -- `interact`. Lays out some pretty common idioms and displays some design 12 | -- methodology. 13 | -- 14 | -- Note the lack of a global "hangman state". All the components of the 15 | -- state --- the current word, the wrong guesses, the player scores, etc. 16 | -- --- are isolated from each other and only interact when needed. The 17 | -- `Puzzle` type only contains information for the console to display the 18 | -- current "output" of the puzzle --- it doesn't even contain the solution. 19 | -- 20 | -- Also, note the principled reading and saving of the game auto using 21 | -- `readAuto` and `writeAuto`. 22 | -- 23 | -- Demonstrates as well some high concepts like building an `Auto` over 24 | -- a monad like `Rand`, and then "sealing away" the randomness. 25 | -- `hangmanRandom` uses an underlying monad to generate new words, and 26 | -- `hangman` "seals away" the randomness of the underlying monad; the 27 | -- entropy is self-contained only in the parts that need it. 28 | -- 29 | -- Also uses `interactAuto` as a high level wrapper to "run" an `Auto` on 30 | -- stdin. The logic for a simple todo app. It is structured so that its 31 | -- "input" are commands, and its output is a map of tasks to task id's. 32 | 33 | 34 | module Main (main) where 35 | 36 | import Control.Auto 37 | import Control.Auto.Blip 38 | import Control.Auto.Effects 39 | import Control.Auto.Interval 40 | import Control.Auto.Switch 41 | import Control.Exception hiding (mask) 42 | import Control.Monad hiding (mapM_, sequence) 43 | import Control.Monad.Random 44 | import Control.Monad.Trans.State 45 | import Data.Char 46 | import Data.Foldable (mapM_) 47 | import Data.List 48 | import Data.Maybe 49 | import Data.Serialize 50 | import Data.Traversable (sequence) 51 | import GHC.Generics 52 | import Prelude hiding ((.), id, mapM_, sequence) 53 | 54 | {-# ANN Puzzle "HLint: ignore Use String" #-} 55 | {-# ANN game "HLint: ignore Use string literal" #-} 56 | 57 | -- Types 58 | data GCommand = Help 59 | | Quit 60 | | HM HMCommand 61 | deriving Show 62 | 63 | data HMCommand = Guess Char 64 | | Solve String 65 | | New 66 | | Display 67 | deriving Show 68 | 69 | data Puzzle = Puzzle { puzzleString :: String -- The "masked" string 70 | , puzzleWrongs :: [Char] -- List of wrong guesses 71 | , puzzleStatus :: Status 72 | } deriving (Show, Generic) 73 | 74 | data Status = InProgress 75 | | Success String 76 | | Failure String 77 | deriving (Show, Generic) 78 | 79 | data PuzzleOut = Puzz Puzzle Bool -- return current puzzle; show score? 80 | | Swap Puzzle Puzzle -- old puzzle, new puzzle 81 | deriving (Show, Generic) 82 | 83 | instance Serialize Puzzle 84 | instance Serialize Status 85 | instance Serialize PuzzleOut 86 | 87 | -- Config 88 | wordlistFP :: FilePath 89 | wordlistFP = "data/wordlist.txt" 90 | 91 | savegameFP :: FilePath 92 | savegameFP = "data/save/hangman" 93 | 94 | guesses :: Int 95 | guesses = 7 96 | 97 | helpmsg :: String 98 | helpmsg = unlines [ "Solve the hangman!" 99 | , "> @new : new game " 100 | , "> @help : display this message " 101 | , "> @display : display score and puzzle" 102 | , "> (any single character) : guess that character " 103 | , "> @solve [sol] : attempt to solve " 104 | , "> @quit : quit " 105 | ] 106 | 107 | 108 | main :: IO () 109 | main = do 110 | putStrLn "Welcome to Hangman! Type @help for help!" 111 | wordlist <- lines . map toLower <$> readFile wordlistFP 112 | g <- getStdGen 113 | 114 | -- Our game Auto; `hangman` with a wordlist and a starting seed 115 | let gameAuto = hangman wordlist g :: Auto' String (Maybe String) 116 | 117 | -- Attempt to load the savefile 118 | loaded <- try (readAuto savegameFP gameAuto) 119 | 120 | -- loadedGame is the loaded/deserialized game auto 121 | loadedGame <- case loaded of 122 | Right (Right a) -> do 123 | putStrLn "Save file found! Restoring game." 124 | return a 125 | Left (_ :: SomeException) -> do 126 | putStrLn "No save file found; creating new game." 127 | return gameAuto 128 | _ -> do 129 | putStrLn "Save file corrupted; creating new game." 130 | return gameAuto 131 | 132 | -- run through one iteration to output the current puzzle 133 | -- `initGame` is the game auto after going through one step 134 | let (str, initGame) = stepAuto' loadedGame "@display" 135 | 136 | -- print out out the current puzzle 137 | mapM_ putStrLn str 138 | 139 | -- here we go, start running the loop with the initialized game auto 140 | -- `finalGame` is the game after the loop has ended. 141 | finalGame <- interactAuto initGame 142 | 143 | -- save the game; serialize and write `finalGame`. 144 | putStrLn $ "Saving game to " <> savegameFP <> "..." 145 | writeAuto savegameFP finalGame 146 | 147 | putStrLn "Goodbye!" 148 | 149 | -- the main game auto 150 | hangman :: Monad m 151 | => [String] -- ^ Word list 152 | -> StdGen -- ^ Random seed 153 | -> Auto m String (Maybe String) 154 | -- ^ ^ 155 | -- | +-- Command line output. Nothing means quit. 156 | -- +-- Command line input 157 | -- hangmanRandom runs under `RandT`/a `MonadRandom` go pull new words, so 158 | -- we "seal away" the randomness with `sealRandom`; see 159 | -- "Control.Auto.Random" documentation for more information, and also 160 | -- `sealState`. Lets the random parts run by themselves and become 161 | -- inaccessible to the outside world. 162 | hangman wordlist g0 = sealRandom_ hangmanRandom g1 163 | where 164 | firstGoal :: String 165 | g1 :: StdGen 166 | (firstGoal, g1) = runRand (uniform wordlist) g0 167 | 168 | -- the whole thing is run over `MonadRandom`, like `Rand g`. This 169 | -- allows anyone to grab a "random word" from thin air using `effect` 170 | -- or `arrM`. 171 | hangmanRandom :: MonadRandom m => Auto m String (Maybe String) 172 | hangmanRandom = proc inp -> do 173 | 174 | -- Primitive command parser 175 | let comm = case words inp of 176 | "@help" :_ -> Just Help 177 | "@quit" :_ -> Just Quit 178 | "@display":_ -> Just (HM Display) 179 | "@solve" :ws -> Just . HM . Solve 180 | . map toLower . unwords $ ws 181 | "@new" :_ -> Just (HM New) 182 | [[c]] | isAlpha c -> Just . HM . Guess . toLower $ c 183 | _ -> Nothing 184 | 185 | case comm of 186 | Nothing -> id -< Just "Unknown command. @help for help." 187 | Just Help -> id -< Just helpmsg 188 | Just Quit -> id -< Nothing 189 | Just (HM hcomm) -> do 190 | -- Puzzle, with the command. `switchFromF` basically creates 191 | -- a new "game" with a new word every time the internal `Auto` 192 | -- emits a blip containing a new word. the initial game is 193 | -- `game wordlist firstgoal`. 194 | puzz <- switchFromF (game wordlist) 195 | (game wordlist firstGoal) -< hcomm 196 | 197 | -- get wins and losses 198 | losses <- countB . emitOn isFailure -< puzz 199 | wins <- countB . emitOn isSuccess -< puzz 200 | 201 | -- display result 202 | id -< Just $ case puzz of 203 | -- just the puzzle 204 | Puzz p False -> display p 205 | -- puzzle + score 206 | Puzz p True -> displayScore (wins, losses) 207 | <> "\n" 208 | <> display p 209 | -- the old puzzle and a new puzzle 210 | Swap p0 p1 -> display p0 211 | <> "\n" 212 | <> displayScore (wins, losses) 213 | <> "\n" 214 | <> display p1 215 | 216 | -- A single game with a single word. Takes in commands and outputs 217 | -- `PuzzleOut`s...with a blip stream containing the next mystery word. 218 | -- `switchF` takes this blip and creates a fresh `game` out of it, 219 | -- starting the cycle all over. 220 | game :: MonadRandom m 221 | => [String] -- ^ wordlist 222 | -> String -- ^ new mystery word 223 | -> Auto m HMCommand (PuzzleOut, Blip String) 224 | -- ^ ^ ^ 225 | -- | | +-- blip stream signaling new game 226 | -- | +-- Output puzzle (or puzzle swap) 227 | -- | 228 | -- +-- Hangman command 229 | game wordlist goal = proc comm -> do 230 | -- get correct guesses, incorrect guesses, and solves 231 | let (corr, incorr, solve) = case comm of 232 | Guess c | c `elem` goal -> (Just c , Nothing , False) 233 | | otherwise -> (Nothing, Just c , False) 234 | Solve s | s == goal -> (Nothing, Nothing , True ) 235 | | otherwise -> (Nothing, Just '*', False) 236 | _ -> (Nothing, Nothing , False) 237 | 238 | -- collect all correct and wrong guesses 239 | rights <- mappendFrom [' '] -< maybeToList corr 240 | wrongs <- reverse <$> accum add [] -< incorr 241 | 242 | -- is it solved? 243 | let solved = solve || all (`elem` rights) goal 244 | 245 | -- did the player run out of guesses? 246 | failed = length wrongs > guesses 247 | 248 | -- make status 249 | status | solved = Success goal 250 | | failed = Failure goal 251 | | otherwise = InProgress 252 | 253 | -- the puzzle object 254 | puzz = Puzzle { puzzleString = map (mask rights) goal 255 | , puzzleWrongs = wrongs 256 | , puzzleStatus = status 257 | } 258 | 259 | -- Just p if there should be a new puzzle (from @new or game over) 260 | mkNew = case comm of 261 | New -> Just (puzz { puzzleStatus = Failure goal }) 262 | _ | solved || failed -> Just puzz 263 | | otherwise -> Nothing 264 | 265 | -- emits whenever a new puzzle is desired 266 | mkNewB <- onJusts -< mkNew 267 | 268 | -- tags each new puzzle with a random string pulled from the word list 269 | -- sequence :: Monad m => (a, m b) -> m (a, b) 270 | newPuzzB <- arrMB (\x -> sequence (x, uniform wordlist)) -< mkNewB 271 | 272 | -- newSwap emits a new `Swap` when `newPuzzB` emits 273 | let newSwapB = uncurry Swap . second blankPuzzle <$> newPuzzB 274 | 275 | -- `swapper` is an Interval that is off a first, and then on (as Just) 276 | -- as soon as `newSwap` emits with a new swapper. 277 | swapper <- hold -< newSwapB 278 | 279 | -- puzzOut: what to display if things are to continue as normal 280 | let puzzOut = Puzz puzz (isDisplay comm) 281 | 282 | id -< (fromMaybe puzzOut swapper, snd <$> newPuzzB) 283 | 284 | where 285 | -- add a unique element to a list. but don't check for uniqueness if 286 | -- '*' (a bad solve) 287 | add ws w = case w of 288 | Just '*' -> '*':ws 289 | Just c | c `notElem` ws -> c :ws 290 | _ -> ws 291 | 292 | -- Utility function to "seal away" the randomness of an `Auto (RandT g m) 293 | -- a b` into a normal `Auto m a b`, with a given initial seed. The 294 | -- randomness is no longer accessible from the outside. 295 | sealRandom_ :: (RandomGen g, Monad m) 296 | => Auto (RandT g m) a b 297 | -> g -> Auto m a b 298 | sealRandom_ = sealState_ . hoistA (StateT . runRandT) 299 | 300 | -- new blank puzzle 301 | blankPuzzle :: String -> Puzzle 302 | blankPuzzle str = Puzzle (map (mask []) str) [] InProgress 303 | 304 | -- mask item if in the given string, unless it is a space 305 | mask :: String -> Char -> Char 306 | mask _ ' ' = ' ' 307 | mask rs c | c `elem` rs = c 308 | | otherwise = '_' 309 | 310 | -- Pretty print a puzzle 311 | display :: Puzzle -> String 312 | display (Puzzle str ws sts) = pre 313 | <> " [" <> str' <> "] " 314 | <> "(" <> ws 315 | <> replicate (guesses + 1 - length ws) '.' 316 | <> ")" 317 | where 318 | (pre, str') = case sts of 319 | InProgress -> ("Active:", str) 320 | Success s -> ("Solved!", s ) 321 | Failure s -> ("Failed!", s ) 322 | 323 | -- Pretty print the score 324 | displayScore :: (Int, Int) -> String 325 | displayScore (w, l) = unwords ["Wins:", show w, "|", "Losses:", show l] 326 | 327 | isFailure :: PuzzleOut -> Bool 328 | isFailure (Swap (Puzzle _ _ (Failure _)) _) = True 329 | isFailure _ = False 330 | 331 | isSuccess :: PuzzleOut -> Bool 332 | isSuccess (Swap (Puzzle _ _ (Success _)) _) = True 333 | isSuccess _ = False 334 | 335 | isDisplay :: HMCommand -> Bool 336 | isDisplay Display = True 337 | isDisplay _ = False 338 | 339 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | auto-examples 2 | ============= 3 | 4 | Various examples to demonstrate features of the in-development [auto][] 5 | library, and also as guides for writing your own applications. API subject to 6 | much change. The online development documentation is kept at 7 | . 8 | 9 | [auto]: https://github.com/mstksg/auto 10 | 11 | Before reading this, check out the [auto README][arm] for a brief overview of 12 | the *auto* library, and its main goals and philosophies :) 13 | 14 | [arm]: https://github.com/mstksg/auto/blob/master/README.md 15 | 16 | Installation instructions: 17 | 18 | ~~~bash 19 | # clone this examples repository 20 | $ git clone https://github.com/mstksg/auto-examples 21 | $ cd auto-examples 22 | 23 | # set up the sandbox, pointing to the library source on-disk 24 | $ cabal sandbox init 25 | 26 | # install 27 | $ cabal install 28 | # ghcjs examples, if desired 29 | $ cabal install --ghcjs 30 | ~~~ 31 | 32 | And the executables should all be in `./.cabal-sandbox/bin` of the 33 | `auto-examples` dir. 34 | 35 | Examples 36 | -------- 37 | 38 | ### [hangman][] 39 | 40 | [hangman]: https://github.com/mstksg/auto-examples/blob/master/src/Hangman.hs 41 | 42 | A fully featured command-line hangman game. Made to demonstrate many 43 | high-level features, like the composition of locally stateful autos with 44 | proc-do notation, implicit serializability, switching, and usage of 45 | `interact`. Lays out some pretty common idioms and displays some design 46 | methodology. 47 | 48 | Note the lack of a global "hangman state". All the components of the state 49 | --- the current word, the wrong guesses, the player scores, etc. --- are 50 | isolated from each other and only interact when needed. The `Puzzle` type only 51 | contains information for the console to display the current "output" of the 52 | puzzle --- it doesn't even contain the solution. 53 | 54 | Also, note the principled reading and saving of the game auto using `readAuto` 55 | and `writeAuto`. 56 | 57 | Demonstrates as well some high concepts like building an `Auto` over a monad 58 | like `Rand`, and then "sealing away" the randomness. `hangmanRandom` uses an 59 | underlying monad to generate new words, and `hangman` "seals away" the 60 | randomness of the underlying monad; the entropy is self-contained only in the 61 | parts that need it. 62 | 63 | Also uses `interactAuto` as a high level wrapper to "run" an `Auto` on stdin. 64 | 65 | Admittedly it's a lot "longer" in terms of lines of code than the simple 66 | explicit-state-passing version (even without the gratuitous whitespace and 67 | commenting). Part of this is because the idea of Hangman is pretty simple. 68 | But I really feel like the whole thing "reads" well, and is in a more 69 | understandable high-level declarative/denotative style than such an approach. 70 | 71 | ### [logger][] 72 | 73 | [logger]: https://github.com/mstksg/auto-examples/blob/master/src/Logger.hs 74 | 75 | Mostly used to demonstrate "automatic serialization". Using the `serializing` 76 | combinator, we transform a normal auto representing a logging process into an 77 | auto that automatically, implicitly, and constantly serializes itself...and 78 | automatically re-loads the saved state on the program initialization. 79 | 80 | Demonstrates also `resetFrom`, which is a basic switcher that allows an `Auto` 81 | to "reset" itself through an output blip stream. 82 | 83 | Also heavy usage of "blip stream" logic and intervals to sort out and manage 84 | the stream of inputs into streams that do things and create outputs. 85 | 86 | ### [chatbot][] 87 | 88 | [chatbot]: https://github.com/mstksg/auto-examples/blob/master/src/Chatbot.hs 89 | 90 | Lots of concepts demonstrated here. In fact, this was one of the motivating 91 | reasons for the entire *auto* library in the first place. 92 | 93 | First, a "real world" interface; the Auto is operated and run over an IRC 94 | server using the [simpleirc][] library. The library waits on messages, runs 95 | the Auto, sends out the outputs, and stores the new Auto. 96 | 97 | [simpleirc]: http://hackage.haskell.org/package/simpleirc 98 | 99 | Secondly, the "monoidal" nature of Auto is taken full advantage of here. Each 100 | individual bot module is a full fledged bot (of type `ChatBot m`, or `ChatBot' 101 | m`). The "final" bot is the `mconcat`/monoid sum of individual modules. The 102 | monoid nature means that pairs of bots can be combined and modified together 103 | and combined with other bots, etc. 104 | 105 | Like legos! :D 106 | 107 | Third --- there is no "global chatbot state". That is, *every module* 108 | maintains *its own internal state*, isolated and unrelated to the other 109 | modules. In the "giant state monad" approach, *even with* using zoom and 110 | stuff from lens...every time you add a stateful module, you *have to change 111 | the global state type*. That is, you'd have to "fit in" the room for the new 112 | state in your global state type. 113 | 114 | In this way, adding a module is as simple as just adding another `(<>)` or 115 | item to the `mconcat` list. Each module is completely self-contained and 116 | maintains its own state; adding a module does not affect a single aspect of 117 | any other part of the code base. 118 | 119 | Fourth, serializing individual components of wires "automatically". We don't 120 | serialize the entire chatbot; we can simply serialize individual Auto 121 | components in the chain. This is because of the type of `serializing' fp`: 122 | 123 | ```haskell 124 | serializing' fp :: MonadIO => Auto m a b -> Auto m a b 125 | ``` 126 | 127 | It basically takes an Auto and returns a Auto that is identical in every 128 | way...except self-reloading and self-serializing. Whenever you use that 129 | transformed Auto as a component of any other one, that individual component 130 | will be self-reloading and self-serializing, even if it's embedded deep in a 131 | complex composition. 132 | 133 | ```haskell 134 | f (serializing' fp a1) (serializing' fp a2) 135 | = serializing' fp (f a1 a2) 136 | ``` 137 | 138 | Also, there is the demonstration of using "lifters", like `perRoom` to 139 | transform a `ChatBot` who can only send messages back to the channel it 140 | received messages to a `ChatBot` who can send messages to any channel. They 141 | behave the same way --- but now they can be combined with other such bots. In 142 | this way, you can write "limited bots", and still have them "play well" and 143 | combine with other bots --- inspired by the principles of Gabriel Gonzalez's 144 | [Functor Design Pattern][fdp]. 145 | 146 | [fdp]: http://www.haskellforall.com/2012/09/the-functor-design-pattern.html 147 | 148 | The individual bots themselves all demonstrate usage of common Auto 149 | combinators, like `accum` (which modifies the state with input continually, 150 | with the given function) --- also much usage of the `Blip` mechanism and 151 | semantics --- much of the bots respond to "blips" --- like detected user 152 | commands, and the day changing. 153 | 154 | Working with streams of blips, "scanning over them" (like `accum` but with 155 | blips), and consolidating blip streams back into normal streams are all 156 | demonstrated. 157 | 158 | ### [recursive][] 159 | 160 | [recursive]: https://github.com/mstksg/auto-examples/blob/master/src/Recursive.hs 161 | 162 | Three simple demonstrations of using recursive bindings. Basically, this 163 | allows you even greater power in specifying relationships, in a graph-like 164 | style. The library (with the help of proc syntax) basically "ties the loop" 165 | *for* you (if it's possible). 166 | 167 | The first demonstration is a Fibonacci sequence, to demonstrate how to 168 | basically step through a recursive series without explicit memoization of 169 | previous values. They're all "accessible" using `delay`, in constant space. 170 | 171 | The second demonstration is a power-of-twos series, using the definition `z_n 172 | = z_(n-1) + z_(n-1)`. Not really anything special, but it's trippy to see 173 | a variable used in a recursive definition of itself! 174 | 175 | The third is a neat implementation of the [PID controller algorithm][pid] in 176 | order to tune an opaque system to a desired setpoint/goal response. 177 | 178 | [pid]: http://en.wikipedia.org/wiki/PID_controller 179 | 180 | The algorithm itself is explained in the program, but one thing important to 181 | note is that this example clearly shows a demonstration on how to "wrangle" 182 | recursive bindings in a way that makes sense. 183 | 184 | The main algorithm is this: 185 | 186 | ~~~haskell 187 | rec let err = target - response 188 | 189 | cumulativeSum <- sumFrom 0 -< err 190 | changes <- deltas -< err 191 | 192 | let adjustment = kp * err 193 | + ki * cumulativeSum 194 | + kd * fromMaybe 0 changes 195 | 196 | control <- sumFrom c0 -< adjustment 197 | 198 | response <- blackbox -< control 199 | ~~~ 200 | 201 | This looks a lot like how you would describe the algorithm from a high level. 202 | "The error is the difference between the goal and the response, and the 203 | cumulative sum is the cumulative sum of the errors. The changes is the deltas 204 | between `err`s. The adjustment is each term multiplied by a constant...the 205 | control is the cumulative sum of the adjustments, and the response is the 206 | result of feeding the control to the black box system. 207 | 208 | This actually doesn't work initially...because...how would you get it started? 209 | Everything depends on everything else. 210 | 211 | The key is that we need to have one value that can get its "first value" 212 | without any other input. That is our "base case", which allows for the 213 | knot-tying to work. 214 | 215 | ~~~haskell 216 | control <- sumFromD c0 -< adjustment 217 | ~~~ 218 | 219 | `sumFromD` is like `sumFrom`, except it outputs `c0` on its first step, before 220 | adding anything. Now, `control` is a value that doesn't "need anything" to 221 | get its first/immediate value, so everything works! 222 | 223 | Alternatively, we can also: 224 | 225 | ~~~haskell 226 | currResponse <- system . delay c0 -< control 227 | ~~~ 228 | 229 | `delay` is like `id`, except it outputs `c0` on its first step (and delays 230 | everything by one). It can output `c0` before receiving anything. Again, the 231 | same goal is reached, and either of these fixes allow for the whole thing to 232 | work. 233 | 234 | This example is intended to be a nice reference sheet when working with 235 | recursive bindings. 236 | 237 | ### [todo][] 238 | 239 | [todo]: https://github.com/mstksg/auto-examples/blob/master/src/Todo.hs 240 | 241 | Roughly following the [TodoMVC][] specs; a todo app with the ability to add, 242 | complete, uncomplete, delete, etc. 243 | 244 | [TodoMVC]: http://todomvc.com 245 | 246 | The actual logic is [here][todo]; a command line client is at 247 | [TodoCmd.hs][], and a javascript client using ghcjs that uses the TodoMVC 248 | style sheets and guidelines are at [TodoJS.hs][]. 249 | 250 | [TodoCmd.hs]: https://github.com/mstksg/auto-examples/blob/master/src/TodoCmd.hs 251 | [TodoJS.hs]: https://github.com/mstksg/auto-examples/blob/master/src/TodoJS.hs 252 | 253 | It demonstrates the architecture of a simple app: Your app itself is an 254 | `Auto`, and your GUI elements/command line parsers simply drop inputs to the 255 | `Auto` in a queue to be processed one-by-one; the outputs are then rendered. 256 | 257 | The app is structured so that the input goes in in one channel, and is 258 | immediately "forked" into several blip streams. Each stream does its work, 259 | and in the end, they results are all recombined together to create the "big 260 | picture". 261 | 262 | Also a good usage of dynamic collections, especially `dynMapF`, to dynamically 263 | store `Auto`s for each task, generating new id's/addresses on the fly while 264 | spawning new tasks. 265 | 266 | The [demo is online][todojs], to try out! 267 | 268 | [todojs]: https://mstksg.github.com/auto-examples/todo 269 | 270 | 271 | ### [life][] 272 | 273 | [life]: https://github.com/mstksg/auto-examples/blob/master/src/Life.hs 274 | 275 | [Conway's Game of Life][cgol] implementation. Demonstration of 276 | non-interactive automation/simulation/cellular automaton. In the technical 277 | aspects, a demonstration of the `rec`/`ArrowLoop` mechanisms for recursive, 278 | graph-like Auto connections. 279 | 280 | [cgol]: http://en.wikipedia.org/wiki/Conway's_Game_of_Life 281 | 282 | I consider this to be another compelling demonstration of the power of 283 | denotative style. The thing is laid out very graph-like, using recursive 284 | bindings, and the entire "step" is, at the (abstracted away) low-level, 285 | finding a fixed point of a graph of functions. Some nice practice with the 286 | various `Blip` combinators, as well! 287 | 288 | I might one day expand this to use a GUI, so you it can also show graphics 289 | applications. 290 | 291 | Experimental 292 | ------------ 293 | 294 | Some things I've just been working on...they aren't really here as good 295 | examples yet, but I'm working on making them fit into the bigger picture :) 296 | 297 | ### [connect4][] 298 | 299 | [connect4]: https://github.com/mstksg/auto-examples/blob/master/src/Experimental/Connect4.hs 300 | 301 | This example has a lot of distinct things involved, and I'm still sort of 302 | working it out for maximum demonstrative purposes. 303 | 304 | 1. It has an AI algorithm -- an implementation of minimax w/ alpha-beta 305 | pruning -- that carries the Auto of the game board with it...and 306 | "progresses it" in a different way down every branch of the game tree. 307 | Instead of passing a parameter with the game state, it passes around "the 308 | game itself", and "runs"/re-clones it for every new branch of the game 309 | tree. 310 | 311 | 2. It demonstrates a safe usage of `lastVal`/`delay`, which is necessary for 312 | working well with recursive bindings. Explicitly using `delay` or 313 | `lastVal` lets you really explicitly say what depends on what, in terms of 314 | time, so you don't go into an infinite loop. 315 | 316 | 3. It uses `mux` and `gather`, which are Auto "multiplexers" and "gatherers". 317 | It uses `mux` to basically manage the pool of "Controllers" (players in 318 | the game), and "run" the desired one, dynamically. `gather` does a 319 | similar thing, except it gathers all of the results so far in an output 320 | Map. 321 | 322 | These are powerful tools for managing dynamic collections of Autos, and 323 | routing the proper messages to the proper ones that need them. 324 | 325 | 4. It uses `fastForward`, which allows you to turn an `Auto m a (Maybe b)` 326 | into an `Auto m a b` by "skipping over" the `Nothing`s, 327 | manipulating/warping time to fit your needs. This is used to allow the 328 | `game'` auto to "ask for input" when it needs input (on `Just request`) 329 | and "skip over and happily run along" when it doesn't (on `Nothing`). 330 | 331 | (Not sure how useful of an abstraction this is at this point...it might be 332 | better to let the actual driver/runner handle it.) 333 | 334 | -------------------------------------------------------------------------------- /src/TodoJS.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Arrows #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE MonadComprehensions #-} 4 | 5 | -- | "Todo-JS" 6 | -- 7 | -- Simple todo app on ghcjs, with logic straight from the non-javascript 8 | -- version; that is, an identical 'Auto'. Mostly a ghcjs wrapper working 9 | -- with GHCJS.DOM ... which is admittedly a little messy. All of the todo 10 | -- logic is in `Todo.hs`, so check that out first :) This is just the 11 | -- "view". 12 | -- 13 | -- https://github.com/mstksg/auto-examples/blob/master/src/Todo.hs 14 | -- 15 | -- If you're building this, be sure to grab the css asset files from the 16 | -- project directory. 17 | -- 18 | -- Still missing persistence to localStorage and routing. While 19 | -- persistance might be a useful demonstration of implicit serialiation, 20 | -- a part of it (and routing too) might be outside of the range of domain 21 | -- of `auto`...so these aren't really high-priority for now. 22 | -- 23 | -- This is compiled and hosted online at: 24 | -- http://mstksg.github.io/auto-examples/todo 25 | 26 | module Main (main) where 27 | 28 | import Control.Applicative 29 | import Control.Auto hiding (All) 30 | import Control.Auto.Run 31 | import Control.Concurrent 32 | import Control.Monad (unless, when) 33 | import Control.Monad.IO.Class 34 | import Data.Foldable (forM_, all) 35 | import Data.IntMap (IntMap) 36 | import Data.Maybe 37 | import Data.Serialize 38 | import GHC.Generics 39 | import GHCJS.DOM 40 | import GHCJS.DOM.Document 41 | import GHCJS.DOM.Element 42 | import GHCJS.DOM.EventM 43 | import GHCJS.DOM.HTMLAnchorElement 44 | import GHCJS.DOM.HTMLButtonElement 45 | import GHCJS.DOM.HTMLElement 46 | import GHCJS.DOM.HTMLInputElement 47 | import GHCJS.DOM.HTMLLabelElement 48 | import GHCJS.DOM.HTMLLinkElement 49 | import GHCJS.DOM.HTMLMetaElement 50 | import GHCJS.DOM.HTMLTitleElement 51 | import GHCJS.DOM.Node 52 | import GHCJS.DOM.Types 53 | import GHCJS.Foreign 54 | import Prelude hiding ((.), id, all) 55 | import Todo 56 | import qualified Data.IntMap.Strict as IM 57 | 58 | data GUIOpts = GUI { _currFilter :: Filter -- currently applied filter 59 | , _currSelected :: Maybe TaskID -- currently selected task 60 | } 61 | 62 | data GUIInp = GIFilter Filter 63 | | GISelect (Maybe TaskID) 64 | 65 | data Filter = All | Active | Completed 66 | deriving (Show, Generic, Enum, Eq) 67 | 68 | instance Serialize Filter 69 | 70 | -- | A new `Auto` that takes in commands from the GUI (that can either be 71 | -- commands for the Todo app logic itself, or commands to change some GUI 72 | -- option). 73 | -- 74 | -- Basically filters the input stream into three different blip streams and 75 | -- recombines them all together in the end. 76 | -- 77 | -- The result is a tuple with all of the alive `Task` items, and GUI option 78 | -- settings. 79 | todoAppGUI :: Auto' (Either TodoInp GUIInp) (IntMap Task, GUIOpts) 80 | todoAppGUI = proc inp -> do 81 | -- process the input items that are for the Todo app itself. pretty 82 | -- much just feeds it to the `todoApp` auto, from `Todo.hs`, which 83 | -- has the actual logic. 84 | outp <- holdWith mempty . perBlip todoApp . emitJusts todoInps -< inp 85 | -- `filt` will be the last seen filter setting inputted, starting with 86 | -- `All`. It is the currently applied filter. 87 | filt <- holdWith All . emitJusts filtInps -< inp 88 | -- `selc` will be the last seen selection setting inputted, starting with 89 | -- `Nothing`. It is the currently selected/edited task. 90 | selc <- holdWith Nothing . emitJusts selcInps -< inp 91 | 92 | id -< (outp, GUI filt selc) 93 | where 94 | -- monad comprehensions to act as primitive lenses/filters 95 | todoInps :: Either TodoInp GUIInp -> Maybe TodoInp 96 | todoInps etg = [ ti | Left ti <- Just etg ] 97 | filtInps :: Either TodoInp GUIInp -> Maybe Filter 98 | filtInps etg = [ filt | Right (GIFilter filt) <- Just etg ] 99 | selcInps :: Either TodoInp GUIInp -> Maybe (Maybe TaskID) 100 | selcInps etg = [ selc | Right (GISelect selc) <- Just etg ] 101 | 102 | 103 | 104 | main :: IO () 105 | main = do 106 | -- The `Chan` queue to dump all commands triggered by GUI actions 107 | inputChan <- newChan :: IO (Chan (Either TodoInp GUIInp)) 108 | 109 | runWebGUI $ \ webView -> do 110 | Just doc <- webViewGetDomDocument webView 111 | 112 | -- render the skeleton, giving a reference to the todo list and the 113 | -- info footer on the DOM 114 | (main_, footer) <- renderInitial doc inputChan 115 | 116 | -- Run the `Auto` `todoAppGUI` on the `inputChan` queue, by waiting 117 | -- for new commands (deposited by the GUI) to show up on the queue, 118 | -- feeding them through `todoAppGUI`, and "rendering" the output 119 | -- with `renderGui doc main_ footer inputChan`. 120 | -- 121 | _ <- runOnChan (renderGui doc main_ footer inputChan) 122 | inputChan 123 | todoAppGUI 124 | 125 | return () 126 | 127 | -- | Set up the "static" skeleton of the GUI that won't be updated. 128 | -- Returns a reference the todo list body and the footer with information. 129 | -- 130 | -- Admittedly pretty hairy, but there's no real "logic" here, only view 131 | -- manipulation. If we had a high-level DOM manipulation library for ghcjs 132 | -- this could probably just be half as long and much more clean. 133 | renderInitial :: Document 134 | -> Chan (Either TodoInp GUIInp) 135 | -> IO (HTMLElement, HTMLElement) 136 | renderInitial doc inputChan = do 137 | Just hd <- documentGetHead doc 138 | 139 | meta <- createAppend doc hd "meta" castToHTMLMetaElement 140 | elementSetAttribute meta "charset" "utf-8" 141 | 142 | title <- createAppend doc hd "title" castToHTMLTitleElement 143 | htmlTitleElementSetText title "auto :: TodoMVC" 144 | 145 | forM_ ["assets/base.css","assets/index.css"] $ \lnk -> do 146 | cssLink <- createAppend doc hd "link" castToHTMLLinkElement 147 | htmlLinkElementSetRel cssLink "stylesheet" 148 | elementSetAttribute cssLink "charset" "utf-8" 149 | elementSetAttribute cssLink "type" "text/css" 150 | htmlLinkElementSetHref cssLink lnk 151 | 152 | Just body <- documentGetBody doc 153 | 154 | todomvc_wrapper <- createAppend doc body "div" castToHTMLDivElement 155 | elementSetClassName todomvc_wrapper "todomvc-wrapper" 156 | 157 | todoapp <- createAppend doc todomvc_wrapper "section" castToHTMLElement 158 | elementSetId todoapp "todoapp" 159 | 160 | header <- createAppend doc todoapp "header" castToHTMLElement 161 | 162 | heading <- createAppend doc header "h1" castToHTMLHeadingElement 163 | htmlElementSetInnerHTML heading "todo" 164 | 165 | new_todo <- createAppend doc header "input" castToHTMLInputElement 166 | elementSetId new_todo "new-todo" 167 | htmlInputElementSetPlaceholder new_todo "What needs to be done?" 168 | htmlInputElementSetAutofocus new_todo True 169 | htmlInputElementSetName new_todo "newTodo" 170 | 171 | -- add an `IAdd` command to the queue whenever a new task is submitted 172 | _ <- elementOnkeypress new_todo $ do 173 | k <- uiKeyCode 174 | when (k == 13) . liftIO $ do 175 | inp <- htmlInputElementGetValue new_todo 176 | unless (null inp) $ do 177 | writeChan inputChan (Left (IAdd inp)) 178 | htmlInputElementSetValue new_todo "" 179 | 180 | main_ <- createAppend doc todoapp "section" castToHTMLElement 181 | elementSetId main_ "main" 182 | 183 | footer <- createAppend doc todoapp "footer" castToHTMLElement 184 | elementSetId footer "footer" 185 | 186 | info <- createAppend doc todomvc_wrapper "footer" castToHTMLElement 187 | elementSetId info "info" 188 | htmlElementSetInnerHTML info $ 189 | "

Double-click to edit a todo

" 190 | <> "

Written by Justin Le on " 191 | <> "ghcjs " 192 | <> "as an auto demo " 193 | <> "(source: logic " 194 | <> "view)

" 195 | <> "

Spec, templates, and assets from TodoMVC

" 196 | 197 | -- one render with initial GUI conditions, to set things up 198 | _ <- renderGui doc main_ footer inputChan (mempty, GUI All Nothing) 199 | 200 | return (main_, footer) 201 | 202 | -- | Render the view for a given "output state" `(IntMap Task, GUIOpts)`, 203 | -- and add the callbacks. 204 | -- 205 | -- One thing to remember that is there is basically no logic going on here. 206 | -- All we are doing is rendering the output of the `Auto` in a "dumb" way, 207 | -- and adding callback hooks to add inputs into the `Chan` queue whenever 208 | -- stuff happens. 209 | -- 210 | -- If we had a nice high-level DOM language this could all pretty much be 211 | -- half as long and very expressive...but yeah, the only "Auto" part is 212 | -- that whenever someone clicks something or does something, it adds a new 213 | -- command to the `Chan` queue. 214 | -- 215 | -- Most of the fancy display tricks are handled with css, anyway :) 216 | renderGui :: Document 217 | -> HTMLElement 218 | -> HTMLElement 219 | -> Chan (Either TodoInp GUIInp) 220 | -> (IntMap Task, GUIOpts) 221 | -> IO Bool 222 | renderGui doc main_ footer inputChan (tasks, GUI filt selc) = do 223 | htmlElementSetHidden main_ (IM.size tasks == 0) 224 | htmlElementSetHidden footer (IM.size tasks == 0) 225 | 226 | htmlElementSetInnerHTML main_ "" 227 | htmlElementSetInnerHTML footer "" 228 | 229 | toggle_all <- createAppend doc main_ "input" castToHTMLInputElement 230 | elementSetAttribute toggle_all "type" "checkbox" 231 | elementSetId toggle_all "toggle-all" 232 | htmlInputElementSetName toggle_all "toggle" 233 | htmlInputElementSetChecked toggle_all allCompleted 234 | 235 | -- send a new command to the queue whenever button is pressed 236 | _ <- elementOnclick toggle_all . liftIO $ do 237 | let newCompl = not allCompleted 238 | writeChan inputChan (Left (IAll (TEComplete newCompl))) 239 | 240 | toggle_all_label <- createAppend doc main_ "label" castToHTMLLabelElement 241 | htmlLabelElementSetHtmlFor toggle_all_label "toggle-all" 242 | htmlElementSetInnerHTML toggle_all_label "Mark all as complete" 243 | 244 | todo_list <- createAppend doc main_ "ul" castToHTMLUListElement 245 | elementSetId todo_list "todo-list" 246 | 247 | _ <- IM.traverseWithKey (renderTask todo_list) tasks' 248 | 249 | todo_count <- createAppend doc footer "span" castToHTMLElement 250 | elementSetId todo_count "todo-count" 251 | htmlElementSetInnerHTML todo_count $ "" 252 | <> show (IM.size uncompl) 253 | <> " tasks left" 254 | 255 | filters <- createAppend doc footer "ul" castToHTMLUListElement 256 | elementSetId filters "filters" 257 | forM_ [All ..] $ \filtType -> do 258 | filtLi <- createAppend doc filters "li" castToHTMLLIElement 259 | 260 | -- send a new command to the queue whenever button is pressed 261 | _ <- elementOnclick filtLi . liftIO $ 262 | writeChan inputChan (Right (GIFilter filtType)) 263 | 264 | filtA <- createAppend doc filtLi "a" castToHTMLAnchorElement 265 | when (filtType == filt) $ elementSetClassName filtA "selected" 266 | htmlAnchorElementSetText filtA (show filtType) 267 | htmlAnchorElementSetHref filtA "javascript:void();" 268 | 269 | 270 | clear_completed <- createAppend doc footer "button" castToHTMLButtonElement 271 | elementSetId clear_completed "clear-completed" 272 | elementSetClassName clear_completed "clear-completed" 273 | htmlElementSetHidden clear_completed (IM.size compl == 0) 274 | htmlElementSetInnerHTML clear_completed $ "Clear completed (" 275 | <> show (IM.size compl) 276 | <> ")" 277 | 278 | -- send a new command to the queue whenever button is pressed 279 | _ <- elementOnclick clear_completed . liftIO $ 280 | writeChan inputChan (Left (IAll TEPrune)) 281 | 282 | 283 | -- tells `runOnChan` that we want to continue. 284 | return True 285 | where 286 | tasks' = case filt of 287 | All -> tasks 288 | Active -> IM.filter (not . taskCompleted) tasks 289 | Completed -> IM.filter taskCompleted tasks 290 | allCompleted = all taskCompleted tasks 291 | (compl, uncompl) = IM.partition taskCompleted tasks 292 | 293 | renderTask :: HTMLUListElement -> TaskID -> Task -> IO () 294 | renderTask todo_list tid t = do 295 | li <- createAppend doc todo_list "li" castToHTMLLIElement 296 | elementSetClassName li . unwords 297 | . map snd . filter fst $ [ (taskCompleted t, "completed") 298 | , (selc == Just tid, "editing") 299 | ] 300 | 301 | view <- createAppend doc li "div" castToHTMLDivElement 302 | elementSetClassName view "view" 303 | 304 | toggle <- createAppend doc view "input" castToHTMLInputElement 305 | elementSetAttribute toggle "type" "checkbox" 306 | elementSetClassName toggle "toggle" 307 | htmlInputElementSetChecked toggle (taskCompleted t) 308 | 309 | -- send a new command to the queue whenever button is pressed 310 | _ <- elementOnclick toggle . liftIO $ do 311 | let newCompl = not (taskCompleted t) 312 | writeChan inputChan (Left (ITask tid (TEComplete newCompl))) 313 | 314 | descr <- createAppend doc view "label" castToHTMLLabelElement 315 | htmlElementSetInnerHTML descr (taskDescr t) 316 | 317 | -- send a new command to the queue whenever button is pressed 318 | _ <- elementOndblclick descr . liftIO $ 319 | writeChan inputChan (Right (GISelect (Just tid))) 320 | 321 | destroy <- createAppend doc view "button" castToHTMLButtonElement 322 | elementSetClassName destroy "destroy" 323 | 324 | _ <- elementOnclick destroy . liftIO $ 325 | writeChan inputChan (Left (ITask tid TEDelete)) 326 | 327 | edit <- createAppend doc li "input" castToHTMLInputElement 328 | elementSetClassName edit "edit" 329 | htmlInputElementSetValue edit (taskDescr t) 330 | htmlInputElementSetName edit "title" 331 | elementSetId edit $ "todo-" <> show tid 332 | 333 | let callback = liftIO $ do 334 | editString <- htmlInputElementGetValue edit 335 | if null editString 336 | then writeChan inputChan (Left (ITask tid TEDelete)) 337 | else do 338 | writeChan inputChan (Left (ITask tid (TEModify editString))) 339 | writeChan inputChan (Right (GISelect Nothing)) 340 | 341 | -- send a new command to the queue whenever button is pressed 342 | _ <- elementOnblur edit callback 343 | _ <- elementOnkeypress edit $ do 344 | k <- uiKeyCode 345 | when (k `elem` [13, 27]) callback 346 | 347 | return () 348 | 349 | 350 | -- Utility function to create an item on the document with a given type and 351 | -- tag and append it to a given parent. 352 | createAppend :: ( IsDocument self 353 | , ToJSString tagName 354 | , IsNode parent 355 | , IsNode b 356 | ) 357 | => self 358 | -> parent 359 | -> tagName 360 | -> (Element -> b) 361 | -> IO b 362 | createAppend doc parent tag coercer = do 363 | c@(Just child) <- fmap coercer <$> documentCreateElement doc tag 364 | _ <- nodeAppendChild parent c 365 | return child 366 | -------------------------------------------------------------------------------- /src/TodoJSOld.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Arrows #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE MonadComprehensions #-} 4 | 5 | -- | "Todo-JS" 6 | -- 7 | -- Simple todo app on ghcjs, with logic straight from the non-javascript 8 | -- version; that is, an identical 'Auto'. Mostly a ghcjs wrapper working 9 | -- with GHCJS.DOM ... which is admittedly a little messy. All of the todo 10 | -- logic is in `Todo.hs`, so check that out first :) This is just the 11 | -- "view". 12 | -- 13 | -- https://github.com/mstksg/auto-examples/blob/master/src/Todo.hs 14 | -- 15 | -- If you're building this, be sure to grab the css asset files from the 16 | -- project directory. 17 | -- 18 | -- Still missing persistence to localStorage and routing. While 19 | -- persistance might be a useful demonstration of implicit serialiation, 20 | -- a part of it (and routing too) might be outside of the range of domain 21 | -- of `auto`...so these aren't really high-priority for now. 22 | -- 23 | -- This is compiled and hosted online at: 24 | -- http://mstksg.github.io/auto-examples/todo 25 | 26 | module Main (main) where 27 | 28 | import Control.Applicative 29 | import Control.Auto hiding (All) 30 | import Control.Auto.Run 31 | import Control.Concurrent 32 | import Control.Monad (unless, when) 33 | import Control.Monad.IO.Class 34 | import Data.Foldable (forM_, all) 35 | import Data.IntMap (IntMap) 36 | import Data.Maybe 37 | import Data.Serialize 38 | import GHC.Generics 39 | import GHCJS.DOM 40 | import GHCJS.DOM.Document 41 | import GHCJS.DOM.Element 42 | import GHCJS.DOM.EventM 43 | import GHCJS.DOM.HTMLAnchorElement 44 | import GHCJS.DOM.HTMLButtonElement 45 | import GHCJS.DOM.HTMLElement 46 | import GHCJS.DOM.HTMLInputElement 47 | import GHCJS.DOM.HTMLLabelElement 48 | import GHCJS.DOM.HTMLLinkElement 49 | import GHCJS.DOM.HTMLMetaElement 50 | import GHCJS.DOM.HTMLTitleElement 51 | import GHCJS.DOM.Node 52 | import GHCJS.DOM.Types 53 | import GHCJS.Foreign 54 | import Prelude hiding ((.), id, all) 55 | import Todo 56 | import qualified Data.IntMap.Strict as IM 57 | 58 | data GUIOpts = GUI { _currFilter :: Filter -- currently applied filter 59 | , _currSelected :: Maybe TaskID -- currently selected task 60 | } 61 | 62 | data GUIInp = GIFilter Filter 63 | | GISelect (Maybe TaskID) 64 | 65 | data Filter = All | Active | Completed 66 | deriving (Show, Generic, Enum, Eq) 67 | 68 | instance Serialize Filter 69 | 70 | -- | A new `Auto` that takes in commands from the GUI (that can either be 71 | -- commands for the Todo app logic itself, or commands to change some GUI 72 | -- option). 73 | -- 74 | -- Basically filters the input stream into three different blip streams and 75 | -- recombines them all together in the end. 76 | -- 77 | -- The result is a tuple with all of the alive `Task` items, and GUI option 78 | -- settings. 79 | todoAppGUI :: Auto' (Either TodoInp GUIInp) (IntMap Task, GUIOpts) 80 | todoAppGUI = proc inp -> do 81 | -- process the input items that are for the Todo app itself. pretty 82 | -- much just feeds it to the `todoApp` auto, from `Todo.hs`, which 83 | -- has the actual logic. 84 | outp <- holdWith mempty . perBlip todoApp . emitJusts todoInps -< inp 85 | -- `filt` will be the last seen filter setting inputted, starting with 86 | -- `All`. It is the currently applied filter. 87 | filt <- holdWith All . emitJusts filtInps -< inp 88 | -- `selc` will be the last seen selection setting inputted, starting with 89 | -- `Nothing`. It is the currently selected/edited task. 90 | selc <- holdWith Nothing . emitJusts selcInps -< inp 91 | 92 | id -< (outp, GUI filt selc) 93 | where 94 | -- monad comprehensions to act as primitive lenses/filters 95 | todoInps :: Either TodoInp GUIInp -> Maybe TodoInp 96 | todoInps etg = [ ti | Left ti <- Just etg ] 97 | filtInps :: Either TodoInp GUIInp -> Maybe Filter 98 | filtInps etg = [ filt | Right (GIFilter filt) <- Just etg ] 99 | selcInps :: Either TodoInp GUIInp -> Maybe (Maybe TaskID) 100 | selcInps etg = [ selc | Right (GISelect selc) <- Just etg ] 101 | 102 | 103 | 104 | main :: IO () 105 | main = do 106 | -- The `Chan` queue to dump all commands triggered by GUI actions 107 | inputChan <- newChan :: IO (Chan (Either TodoInp GUIInp)) 108 | 109 | runWebGUI $ \ webView -> do 110 | Just doc <- webViewGetDomDocument webView 111 | 112 | -- render the skeleton, giving a reference to the todo list and the 113 | -- info footer on the DOM 114 | (main_, footer) <- renderInitial doc inputChan 115 | 116 | -- Run the `Auto` `todoAppGUI` on the `inputChan` queue, by waiting 117 | -- for new commands (deposited by the GUI) to show up on the queue, 118 | -- feeding them through `todoAppGUI`, and "rendering" the output 119 | -- with `renderGui doc main_ footer inputChan`. 120 | -- 121 | _ <- runOnChan (renderGui doc main_ footer inputChan) 122 | inputChan 123 | todoAppGUI 124 | 125 | return () 126 | 127 | -- | Set up the "static" skeleton of the GUI that won't be updated. 128 | -- Returns a reference the todo list body and the footer with information. 129 | -- 130 | -- Admittedly pretty hairy, but there's no real "logic" here, only view 131 | -- manipulation. If we had a high-level DOM manipulation library for ghcjs 132 | -- this could probably just be half as long and much more clean. 133 | renderInitial :: Document 134 | -> Chan (Either TodoInp GUIInp) 135 | -> IO (HTMLElement, HTMLElement) 136 | renderInitial doc inputChan = do 137 | Just hd <- documentGetHead doc 138 | 139 | meta <- createAppend doc hd "meta" castToHTMLMetaElement 140 | elementSetAttribute meta "charset" "utf-8" 141 | 142 | title <- createAppend doc hd "title" castToHTMLTitleElement 143 | htmlTitleElementSetText title "auto :: TodoMVC" 144 | 145 | forM_ ["assets/base.css","assets/index.css"] $ \lnk -> do 146 | cssLink <- createAppend doc hd "link" castToHTMLLinkElement 147 | htmlLinkElementSetRel cssLink "stylesheet" 148 | elementSetAttribute cssLink "charset" "utf-8" 149 | elementSetAttribute cssLink "type" "text/css" 150 | htmlLinkElementSetHref cssLink lnk 151 | 152 | Just body <- documentGetBody doc 153 | 154 | todomvc_wrapper <- createAppend doc body "div" castToHTMLDivElement 155 | elementSetClassName todomvc_wrapper "todomvc-wrapper" 156 | 157 | todoapp <- createAppend doc todomvc_wrapper "section" castToHTMLElement 158 | elementSetId todoapp "todoapp" 159 | 160 | header <- createAppend doc todoapp "header" castToHTMLElement 161 | 162 | heading <- createAppend doc header "h1" castToHTMLHeadingElement 163 | htmlElementSetInnerHTML heading "todo" 164 | 165 | new_todo <- createAppend doc header "input" castToHTMLInputElement 166 | elementSetId new_todo "new-todo" 167 | htmlInputElementSetPlaceholder new_todo "What needs to be done?" 168 | htmlInputElementSetAutofocus new_todo True 169 | htmlInputElementSetName new_todo "newTodo" 170 | 171 | -- add an `IEAdd` command to the queue whenever a new task is submitted 172 | _ <- elementOnkeypress new_todo $ do 173 | k <- uiKeyCode 174 | when (k == 13) . liftIO $ do 175 | inp <- htmlInputElementGetValue new_todo 176 | unless (null inp) $ do 177 | writeChan inputChan (Left (IEAdd inp)) 178 | htmlInputElementSetValue new_todo "" 179 | 180 | main_ <- createAppend doc todoapp "section" castToHTMLElement 181 | elementSetId main_ "main" 182 | 183 | footer <- createAppend doc todoapp "footer" castToHTMLElement 184 | elementSetId footer "footer" 185 | 186 | info <- createAppend doc todomvc_wrapper "footer" castToHTMLElement 187 | elementSetId info "info" 188 | htmlElementSetInnerHTML info $ 189 | "

Double-click to edit a todo

" 190 | <> "

Written by Justin Le on " 191 | <> "ghcjs " 192 | <> "as an auto demo " 193 | <> "(source: logic " 194 | <> "view)

" 195 | <> "

Spec, templates, and assets from TodoMVC

" 196 | 197 | -- one render with initial GUI conditions, to set things up 198 | _ <- renderGui doc main_ footer inputChan (mempty, GUI All Nothing) 199 | 200 | return (main_, footer) 201 | 202 | -- | Render the view for a given "output state" `(IntMap Task, GUIOpts)`, 203 | -- and add the callbacks. 204 | -- 205 | -- One thing to remember that is there is basically no logic going on here. 206 | -- All we are doing is rendering the output of the `Auto` in a "dumb" way, 207 | -- and adding callback hooks to add inputs into the `Chan` queue whenever 208 | -- stuff happens. 209 | -- 210 | -- If we had a nice high-level DOM language this could all pretty much be 211 | -- half as long and very expressive...but yeah, the only "Auto" part is 212 | -- that whenever someone clicks something or does something, it adds a new 213 | -- command to the `Chan` queue. 214 | -- 215 | -- Most of the fancy display tricks are handled with css, anyway :) 216 | renderGui :: Document 217 | -> HTMLElement 218 | -> HTMLElement 219 | -> Chan (Either TodoInp GUIInp) 220 | -> (IntMap Task, GUIOpts) 221 | -> IO Bool 222 | renderGui doc main_ footer inputChan (tasks, GUI filt selc) = do 223 | htmlElementSetHidden main_ (IM.size tasks == 0) 224 | htmlElementSetHidden footer (IM.size tasks == 0) 225 | 226 | htmlElementSetInnerHTML main_ "" 227 | htmlElementSetInnerHTML footer "" 228 | 229 | toggle_all <- createAppend doc main_ "input" castToHTMLInputElement 230 | elementSetAttribute toggle_all "type" "checkbox" 231 | elementSetId toggle_all "toggle-all" 232 | htmlInputElementSetName toggle_all "toggle" 233 | htmlInputElementSetChecked toggle_all allCompleted 234 | 235 | -- send a new command to the queue whenever button is pressed 236 | _ <- elementOnclick toggle_all . liftIO $ do 237 | let newCompl = not allCompleted 238 | writeChan inputChan (Left (IEAll (TEComplete newCompl))) 239 | 240 | toggle_all_label <- createAppend doc main_ "label" castToHTMLLabelElement 241 | htmlLabelElementSetHtmlFor toggle_all_label "toggle-all" 242 | htmlElementSetInnerHTML toggle_all_label "Mark all as complete" 243 | 244 | todo_list <- createAppend doc main_ "ul" castToHTMLUListElement 245 | elementSetId todo_list "todo-list" 246 | 247 | _ <- IM.traverseWithKey (renderTask todo_list) tasks' 248 | 249 | todo_count <- createAppend doc footer "span" castToHTMLElement 250 | elementSetId todo_count "todo-count" 251 | htmlElementSetInnerHTML todo_count $ "" 252 | <> show (IM.size uncompl) 253 | <> " tasks left" 254 | 255 | filters <- createAppend doc footer "ul" castToHTMLUListElement 256 | elementSetId filters "filters" 257 | forM_ [All ..] $ \filtType -> do 258 | filtLi <- createAppend doc filters "li" castToHTMLLIElement 259 | 260 | -- send a new command to the queue whenever button is pressed 261 | _ <- elementOnclick filtLi . liftIO $ 262 | writeChan inputChan (Right (GIFilter filtType)) 263 | 264 | filtA <- createAppend doc filtLi "a" castToHTMLAnchorElement 265 | when (filtType == filt) $ elementSetClassName filtA "selected" 266 | htmlAnchorElementSetText filtA (show filtType) 267 | htmlAnchorElementSetHref filtA "javascript:void();" 268 | 269 | 270 | clear_completed <- createAppend doc footer "button" castToHTMLButtonElement 271 | elementSetId clear_completed "clear-completed" 272 | elementSetClassName clear_completed "clear-completed" 273 | htmlElementSetHidden clear_completed (IM.size compl == 0) 274 | htmlElementSetInnerHTML clear_completed $ "Clear completed (" 275 | <> show (IM.size compl) 276 | <> ")" 277 | 278 | -- send a new command to the queue whenever button is pressed 279 | _ <- elementOnclick clear_completed . liftIO $ 280 | writeChan inputChan (Left (IEAll TEPrune)) 281 | 282 | 283 | -- tells `runOnChan` that we want to continue. 284 | return True 285 | where 286 | tasks' = case filt of 287 | All -> tasks 288 | Active -> IM.filter (not . taskCompleted) tasks 289 | Completed -> IM.filter taskCompleted tasks 290 | allCompleted = all taskCompleted tasks 291 | (compl, uncompl) = IM.partition taskCompleted tasks 292 | 293 | renderTask :: HTMLUListElement -> TaskID -> Task -> IO () 294 | renderTask todo_list tid t = do 295 | li <- createAppend doc todo_list "li" castToHTMLLIElement 296 | elementSetClassName li . unwords 297 | . map snd . filter fst $ [ (taskCompleted t, "completed") 298 | , (selc == Just tid, "editing") 299 | ] 300 | 301 | view <- createAppend doc li "div" castToHTMLDivElement 302 | elementSetClassName view "view" 303 | 304 | toggle <- createAppend doc view "input" castToHTMLInputElement 305 | elementSetAttribute toggle "type" "checkbox" 306 | elementSetClassName toggle "toggle" 307 | htmlInputElementSetChecked toggle (taskCompleted t) 308 | 309 | -- send a new command to the queue whenever button is pressed 310 | _ <- elementOnclick toggle . liftIO $ do 311 | let newCompl = not (taskCompleted t) 312 | writeChan inputChan (Left (IETask tid (TEComplete newCompl))) 313 | 314 | descr <- createAppend doc view "label" castToHTMLLabelElement 315 | htmlElementSetInnerHTML descr (taskDescr t) 316 | 317 | -- send a new command to the queue whenever button is pressed 318 | _ <- elementOndblclick descr . liftIO $ 319 | writeChan inputChan (Right (GISelect (Just tid))) 320 | 321 | destroy <- createAppend doc view "button" castToHTMLButtonElement 322 | elementSetClassName destroy "destroy" 323 | 324 | _ <- elementOnclick destroy . liftIO $ 325 | writeChan inputChan (Left (IETask tid TEDelete)) 326 | 327 | edit <- createAppend doc li "input" castToHTMLInputElement 328 | elementSetClassName edit "edit" 329 | htmlInputElementSetValue edit (taskDescr t) 330 | htmlInputElementSetName edit "title" 331 | elementSetId edit $ "todo-" <> show tid 332 | 333 | let callback = liftIO $ do 334 | editString <- htmlInputElementGetValue edit 335 | if null editString 336 | then writeChan inputChan (Left (IETask tid TEDelete)) 337 | else do 338 | writeChan inputChan (Left (IETask tid (TEModify editString))) 339 | writeChan inputChan (Right (GISelect Nothing)) 340 | 341 | -- send a new command to the queue whenever button is pressed 342 | _ <- elementOnblur edit callback 343 | _ <- elementOnkeypress edit $ do 344 | k <- uiKeyCode 345 | when (k `elem` [13, 27]) callback 346 | 347 | return () 348 | 349 | 350 | -- Utility function to create an item on the document with a given type and 351 | -- tag and append it to a given parent. 352 | createAppend :: ( IsDocument self 353 | , ToJSString tagName 354 | , IsNode parent 355 | , IsNode b 356 | ) 357 | => self 358 | -> parent 359 | -> tagName 360 | -> (Element -> b) 361 | -> IO b 362 | createAppend doc parent tag coercer = do 363 | c@(Just child) <- fmap coercer <$> documentCreateElement doc tag 364 | _ <- nodeAppendChild parent c 365 | return child 366 | -------------------------------------------------------------------------------- /src/Experimental/Connect4.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Arrows #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE TupleSections #-} 4 | {-# LANGUAGE LambdaCase #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | 7 | -- | Usage: 8 | -- 9 | -- $ connect4 [controller X] [controller O] 10 | -- 11 | -- Controllers: 12 | -- * h : human 13 | -- * cR: computer (random moves) 14 | -- * cE: computer (easy) 15 | -- * cH: computer (sorta hard) 16 | -- 17 | -- Defaults to h vs cH 18 | -- 19 | 20 | module Main (main) where 21 | 22 | import Control.Auto hiding (loop) 23 | import Control.Auto.Blip 24 | import Control.Auto.Collection 25 | import Control.Auto.Process.Random 26 | import Control.Auto.Switch 27 | import Control.Auto.Time 28 | import Control.Monad 29 | import Control.Monad.Fix 30 | import Data.Foldable (toList) 31 | import Data.Function hiding ((.), id) 32 | import Data.Functor.Identity 33 | import Data.List 34 | import Data.Maybe 35 | import Data.Ord 36 | import Data.Serialize 37 | import GHC.Generics 38 | import Prelude hiding ((.), id, mapM_) 39 | import System.Console.ANSI 40 | import System.Environment 41 | import System.Random 42 | import qualified Data.Map.Strict as M 43 | 44 | -- Types 45 | type Board = [Column] 46 | type Column = [Piece] 47 | type Player = Piece 48 | 49 | -- The Piece type, also representing a player. 50 | data Piece = X | O deriving (Show, Read, Eq, Ord, Generic) 51 | 52 | -- The output of the 'Board' Auto that allows the other Autos and stuff to 53 | -- display it and react to it. Contains the board, the winner (Nothing 54 | -- if no winner, Just (Just p) if p won, and Just Nothing if a tie), the 55 | -- next player up, and if the last move failed. 56 | data BoardOut = BoardOut { _boBoard :: !Board 57 | , _boWinner :: !(Maybe (Maybe Player)) 58 | , _boNext :: !Player 59 | , _boFailed :: !Bool 60 | } deriving Generic 61 | 62 | -- The type of the generic controllers (human, CPU, etc). If the output is 63 | -- Just, it means...that's the move it wants to make. If the output is 64 | -- Nothing, then the Controller is "asking" for a User input (the Maybe 65 | -- Int). 66 | type Controller m = Auto m (Maybe Int, BoardOut) (Maybe Int) 67 | -- ^ ^ ^ 68 | -- | | +-- Possible output 69 | -- | +-- Game output, for decision making 70 | -- +-- Possible user input 71 | 72 | instance Serialize Piece 73 | instance Serialize BoardOut 74 | 75 | -- config, and initializations 76 | boardWidth, boardHeight :: Int 77 | boardWidth = 7 78 | boardHeight = 6 79 | 80 | emptyBoard :: Board 81 | emptyBoard = replicate boardWidth [] 82 | 83 | emptyBoardOut :: BoardOut 84 | emptyBoardOut = BoardOut emptyBoard Nothing X False 85 | 86 | main :: IO () 87 | main = do 88 | -- build the two controllers, from command line arguments. 89 | args <- getArgs 90 | (cX, cO) <- case args of 91 | [] -> (,) <$> interfOf "h" <*> interfOf "cH" 92 | cO:[] -> (,) <$> interfOf "h" <*> interfOf cO 93 | cX:cO:_ -> (,) <$> interfOf cX <*> interfOf cO 94 | 95 | -- The initial game Auto 96 | let gameAuto = game cX cO 97 | 98 | -- off we go! 99 | loop gameAuto 0 100 | where 101 | -- Build controllers from command line arguments. 102 | interfOf :: MonadFix m => String -> IO (Controller m) 103 | interfOf "cH" = cpuAlphaBeta 8 <$> newStdGen 104 | interfOf "cE" = cpuAlphaBeta 4 <$> newStdGen 105 | interfOf "cR" = cpuRandom <$> newStdGen 106 | interfOf _ = return human 107 | 108 | -- the main loop 109 | loop a i0 = do 110 | let (bout, a') = stepAuto' a i0 111 | clearScreen 112 | putStrLn (showOut bout) 113 | when (isNothing (_boWinner bout)) $ do 114 | i1 <- fromMaybe 0 . readMaybe <$> getLine 115 | loop a' i1 116 | 117 | -- the main game Auto. Given two controllers. 118 | -- 119 | -- Controllers are just a type alias for a normal Auto: 120 | -- 121 | -- > type Controller m = Auto m (Maybe Int, BoardOut) (Maybe Int) 122 | -- 123 | -- See the definition of the type for details on what each field means. 124 | game :: forall m. MonadFix m 125 | => Controller m -- ^ X Player 126 | -> Controller m -- ^ O Player 127 | -> Auto m Int BoardOut -- ^ Game Auto 128 | -- ^ ^ 129 | -- | +-- Game output 130 | -- +-- Player input 131 | -- game is the "fastForwarded" @game'@ Auto. 132 | -- 133 | -- > fastFoward :: a -> Auto m a (Maybe b) -> Auto m a b 134 | -- 135 | -- Basically, 'fastFoward' takes a default value and an Auto returning 136 | -- 'Maybe b', and then, whenever that Auto is "run"/ticked, it repeatedly 137 | -- runs the Auto until it gets a 'Just' result. It is initially run with 138 | -- the input, and then afterwards "fast forwarded" with the default 139 | -- input. In essense, you get an Auto that "always returns 'Just'"...by 140 | -- "fast fowarding" over the 'Nothing's. Like TiVo! 141 | -- 142 | game cX cO = fastForward Nothing game' <<^ Just 143 | where 144 | -- the fast-forwarded game Auto. It feeds the input directly to the 145 | -- Controller whose current turn it is, and then outputs a 'Just' 146 | -- containing the resulting 'BoardOut' whenever an controller 147 | -- "requests" player input. Also outputs a 'Just' when the game is 148 | -- over. 149 | game' :: Auto m (Maybe Int) (Maybe BoardOut) 150 | -- ^ ^ 151 | -- | +-- Board output, if player interaction is 152 | -- | needed, or game is over. 153 | -- +-- Player interaction, if this is a 154 | -- "non-fastforwarded" tick. 155 | game' = proc i -> do 156 | -- the current BoardOut, bout, is the "last value" of newBout. 157 | -- We will use this to give to our controllers, so that they 158 | -- can decide their next moves. 159 | rec bout <- lastVal emptyBoardOut -< newBout 160 | -- feed (i, bout) (the player input, and the current board) to 161 | -- the player playing next, _boNext bout. 162 | -- 163 | -- 'mux' is an Auto multiplexer. Give it an address/key 164 | -- (_boNext bout, the next player), and it'll feed the input 165 | -- (i, bout) to the Auto produced by that key, and output the 166 | -- result. 167 | -- 168 | -- For example, if you pass in (X, (Just 1, bout)), then it'll 169 | -- pass in (Just 1, bout) to the X Auto. 'interf' is the 170 | -- function that maps the key to the Auto, so the X Auto is 171 | -- 'interf X' = 'cX', the X controller. 172 | move <- mux interf -< (_boNext bout, (i, bout)) 173 | 174 | -- feed the retrieved move into the Board auto. 175 | newBout <- board emptyBoard X -< fromMaybe 0 move 176 | 177 | -- the output of the Auto. 178 | let output = case _boWinner newBout of 179 | -- if a winner, just report the new BoardOut 180 | Just _ -> Just newBout 181 | -- If no winner... 182 | Nothing -> case move of 183 | -- if a move was received from an 184 | -- Controller, all is good; no need to 185 | -- output anything. The "fast 186 | -- forwarding" continues. 187 | Just _ -> Nothing 188 | -- if no move is received from an 189 | -- controller, then we need to spark 190 | -- some player interaction. Return 191 | -- a Just to "halt" the 192 | -- fast-forwarding, and ask for input. 193 | Nothing -> Just newBout 194 | 195 | -- spit out the output. 196 | id -< output 197 | 198 | -- the correct controller for the player piece. 199 | interf X = cX 200 | interf O = cO 201 | 202 | 203 | -- board: behave like 'board b0 p0' until a 'Blip' is received...then 204 | -- switch permanently to the 'gameOver' Auto. See the 'hangman' example 205 | -- for more information on 'switchFromF'. 206 | board :: MonadFix m 207 | => Board -- ^ initial Board 208 | -> Player -- ^ initial Player 209 | -> Auto m Int BoardOut 210 | -- ^ ^ 211 | -- | +-- Resulting board 212 | -- +-- Move to make 213 | board b0 p0 = switchFromF gameOver (board' b0 p0) 214 | where 215 | -- gameOver: repeatedly just return the finished BoardOut, ignoring any 216 | -- input...but every move is a failed move (of course). 217 | gameOver b = (pure b' &&& id) . never 218 | where 219 | b' = b { _boFailed = True } 220 | 221 | -- The main Board Auto. 222 | board' :: forall m. MonadFix m 223 | => Board -- ^ initial Board 224 | -> Player -- ^ initial Player 225 | -> Auto m Int (BoardOut, Blip BoardOut) 226 | -- ^ ^ ^ 227 | -- | | +-- switch to Game Over, with this 228 | -- | | BoardOut. 229 | -- | +-- the resulting Board after the move 230 | -- +-- the move to make. 231 | board' b0 p0 = proc i -> do 232 | 233 | -- wasGood: whether or not the previously attempted move was legal. 234 | rec wasGood <- lastVal False -< goodMove 235 | 236 | -- currP: the current player. Will be "swapped" if the last move 237 | -- was good, and kept the same if it wasn't. 238 | currP <- accum swapP p0 -< wasGood 239 | 240 | -- brd: the Board. uses the 'gather' combinator, which is like the 241 | -- 'mux' combinator, but instead of outputting just the "currently 242 | -- running/requested" Auto, it outputs the result of every Auto so 243 | -- far. Here, it holds every 'column' Auto, and runs the one given 244 | -- by 'i' (the move). Gives the 'column' Auto its input, a piece 245 | -- ('currP'). 246 | -- 247 | -- (toList . fill) fills in the resulting Map as appropriate, and 248 | -- then turns it back into a list of lists (a 'Board'). 249 | -- 250 | -- It needs to be filled because 'gather' "accumultes new columns", 251 | -- as you enter in new moves. So on the first move, if you put 252 | -- a move in column 4, gather will be a Map with keys [4]. In 253 | -- the next move, if you put a move in column 2, gather will 254 | -- return a Map with keys [4,2]. 'fill' fills in the gap and 255 | -- replaces the missing keys/values in the map from the starting 256 | -- columns in 'b0'. 257 | brd <- toList . fill <$> gather col -< (i, currP) 258 | 259 | -- lastBrd: The previous board, before the new move. 260 | lastBrd <- lastVal b0 -< brd 261 | 262 | -- a good move is whether or not the previous board is the same as 263 | -- the new, updated board (the move was not rejected) 264 | let goodMove = lastBrd /= brd 265 | 266 | -- the winner. Just (Just p) if p won, Just Nothing if a tie, and 267 | -- Nothing if the game is still in progress. 268 | let winner | isWinner currP brd = Just (Just currP) 269 | | length (concat brd) >= d = Just Nothing 270 | | otherwise = Nothing 271 | 272 | -- 'win' is a Blip that occurs as soon as 'winner' changes. 'winner' 273 | -- is initially Nothing, so this basically means, it is emitted 274 | -- whenever someone wins or there is a tie. 275 | win <- onChange -< winner 276 | 277 | -- the resulting BoardOut for this tick. 278 | let boardOut = BoardOut brd 279 | winner 280 | (swapP currP goodMove) 281 | (not goodMove) 282 | 283 | -- pop out the BoardOut, and the 'win', "tagged" with the BoardOut, 284 | -- when it occurs. 285 | id -< (boardOut, boardOut <$ win) 286 | where 287 | -- if in the right width 288 | inRange n = n > 0 && n <= length b0 289 | -- number of tiles on the full board 290 | d = boardHeight * boardWidth 291 | -- fill the resulting map from 'gather' with the missing columns. See 292 | -- the binding of 'brd' for more information. 293 | fill = flip M.union (M.fromList (zip [1..] b0)) 294 | 295 | -- the starting Auto for every column. If the column number is not in 296 | -- range, it is an always-Nothing. If the column is, it's a 'column' 297 | -- Auto, with starting confirguration given by b0 !! (n - 1). 298 | -- 299 | -- 'gather' works by "pruning" 'Nothing' results, so the out-of-range 300 | -- columns are instantly pruned, and the in-range columns are forever 301 | -- a part of 'gather'. 302 | col :: Int -> Auto m Piece (Maybe Column) 303 | col n | inRange n = Just <$> column (b0 !! (n - 1)) 304 | | otherwise = pure Nothing 305 | -- swap the player, if the Bool 's' ("if the last move was good or 306 | -- not") is True. 307 | swapP p s | s = opp p 308 | | otherwise = p 309 | 310 | -- the actual 'column' Auto, of which every 'board' is composed out of. 311 | -- This is a basic usage of 'accum', which is sort of like an Auto 312 | -- foldl. Give the initial accumulator, and a merging function, apply 313 | -- the function to every incoming item and the accumulator to get a new 314 | -- accumulator and output value. 315 | -- 316 | -- In our case, we simply add the new incoming piece to the accumulator (a 317 | -- column), and then 'take' only the amount that we need, keeping the 318 | -- height of the column at most 'boardHeight'. 319 | column :: Monad m => Column -> Auto m Piece Column 320 | column = accum (\ps p -> take boardHeight (ps ++ [p])) 321 | 322 | 323 | -- Utilities 324 | 325 | -- check for winner 326 | isWinner :: Player -> Board -> Bool 327 | isWinner p b = (any . any) hasFour [ filled , transpose filled 328 | , wedgeUp, wedgeDown 329 | ] 330 | where 331 | hasFour (j:k:l:m:ns) | and [j,k,l,m] = True 332 | | otherwise = hasFour (k:l:m:ns) 333 | hasFour _ = False 334 | filled = map (take boardHeight . (++ repeat False) . map (== p)) b 335 | wedge = take boardWidth . inits $ repeat False 336 | wedgeUp = transpose $ zipWith (++) wedge filled 337 | wedgeDown = transpose $ zipWith (++) (reverse wedge) filled 338 | 339 | -- show the Board 340 | showBoard :: Board -> String 341 | showBoard = unlines . map concat 342 | . transpose . map fill 343 | where 344 | fill :: [Piece] -> [String] 345 | fill = map (++ "|") . reverse . take boardHeight . (++ repeat "_") . map show 346 | 347 | -- show a BoardOut 348 | showOut :: BoardOut -> String 349 | showOut (BoardOut brd winner nextP _) = 350 | unlines [ unwords (map show [1..boardWidth]) 351 | , showBoard brd 352 | , case winner of 353 | Nothing -> "To play: " ++ show nextP 354 | Just w -> "Game over! " ++ case w of 355 | Just p -> "Winner: " ++ show p 356 | Nothing -> "Tie game." 357 | ] 358 | 359 | -- swap a piece/player. 360 | opp :: Piece -> Piece 361 | opp X = O 362 | opp O = X 363 | 364 | -- read, possibly failing with a 'Nothing'. 365 | readMaybe :: Read a => String -> Maybe a 366 | readMaybe = fmap fst . listToMaybe . reads 367 | 368 | 369 | 370 | -- Controller & AI 371 | 372 | -- Ord-to-bound promoter for AI purposes and fast comparisons. 373 | data Bounder a = BMin | BIn a | BMax deriving (Eq, Show, Generic) 374 | 375 | instance Ord a => Ord (Bounder a) where 376 | compare BMin BMin = EQ 377 | compare BMin _ = LT 378 | compare BMax BMax = EQ 379 | compare BMax _ = GT 380 | compare (BIn _) BMin = GT 381 | compare (BIn _) BMax = LT 382 | compare (BIn x) (BIn y) = compare x y 383 | 384 | instance Serialize a => Serialize (Bounder a) 385 | 386 | -- a human controller. Basically, whatever is received is what is 387 | -- outputted. Remember that an Controller receives a (Maybe Int, 388 | -- BoardOut), and outputs a (Maybe Int). So 'arr fst' just echos out 389 | -- that Maybe Int. 390 | -- 391 | -- So, when there is user input (Just), echo out that user input. When 392 | -- there isn't any (Nothing), "request" new input (Nothing). 393 | human :: Monad m => Controller m 394 | human = arr fst 395 | 396 | -- A randomized controller. Ignores its input and outputs Just a random 397 | -- number between 1 and boardWidth at every tick. Never requires user 398 | -- input. 399 | cpuRandom :: Monad m => StdGen -> Controller m 400 | cpuRandom g = Just <$> stdRands (randomR (1, boardWidth)) g 401 | 402 | -- CPU controller with minimax featuring alpha beta pruning. A somewhat 403 | -- minimal understanding of the minimax + α/β pruning algorithm is 404 | -- assumed :) 405 | -- 406 | -- Right now the heuristic isn't too sophisticated. It rates a victory as 407 | -- +infinity, a loss as -infinity, and neither as 0 ;D 408 | -- 409 | -- Implements a "retry" feature: if it sees that the opponent can 410 | -- potentially force a win several moves ahead, it actually re-tries the 411 | -- search with a smaller lookahead. This is because often times, the 412 | -- algorithm will spot a forced victory before the opponent does...and it 413 | -- would just throw up its hands and give up. The retry allows it to try 414 | -- again and try to optimize for the short-term instead of the long-term. 415 | cpuAlphaBeta :: MonadFix m 416 | => Int -- ^ the suggested lookahead 417 | -> StdGen -- ^ shuffling seed 418 | -> Controller m 419 | cpuAlphaBeta lim g = proc (_, bout) -> do 420 | -- lastRetry is whether or not the last "tick" resulted in a retry. 421 | rec lastRetry <- lastVal False -< retry 422 | 423 | -- currP: current (maximizing) player. 424 | let currP = _boNext bout 425 | -- bo0: the initial BoardOut 426 | bo0 = _boBoard bout 427 | -- a0: the initial board Auto 428 | a0 = board bo0 currP 429 | -- lim: the true lookahead limit. is constrained to 2 if the 430 | -- last move resulted in a retry, or else the number of 431 | -- pieces on the board, so we don't waste time doing an 432 | -- expensive search on the first few moves of the game. 433 | lim' | lastRetry = 2 434 | | otherwise = min (length (concat bo0) * 2) lim 435 | 436 | -- weights on which to assign potential moves, if it comes down to 437 | -- a random choice between equally good moves. 438 | -- 439 | -- stdRands (random g) outputs a new random Double every tick. 440 | -- 'accelerate boardWidth' makes it output 'boardWidth' Doubles 441 | -- every tick, in a list. 442 | weights <- accelerate boardWidth (stdRands random g) -< () 443 | 444 | -- order in which to check the moves. basically a fisher-yates 445 | -- shuffle based on 'weights' 446 | let checkOrder = map fst . sortBy (comparing snd) 447 | . zip [1 .. boardWidth] 448 | $ (weights :: [Double]) 449 | -- result, goal: the result of the minimax algorithm. result 450 | -- is the best move, and goal is the "best we can do if the 451 | -- opponent plays perfectly" position after that move is 452 | -- made. 453 | (res, gl) = maxi checkOrder currP lim' BMin BMax a0 454 | -- retry: if this should be a retry. That is, if the opponent 455 | -- can force a win --- of gl, the "best we can do if the 456 | -- opponent plays perfectly", is a loss. 457 | retry = gl == BMin && not lastRetry 458 | -- the actual result to output. If 'res' is Nothing (the maxi 459 | -- algorithm doesn't find any valid moves), then just output 460 | -- a random result instead. 461 | trueRes = res <|> Just (head checkOrder) 462 | 463 | id -< if retry 464 | -- if a retry is desired, we output a bogus move that the 465 | -- 'board' auto will reject, so it'll "retry" us for another 466 | -- reuslt. 467 | then Just 0 468 | -- otherwise, here's the move! 469 | else trueRes 470 | where 471 | -- minimax. Nothing too related to 'Auto' here...mostly just 472 | -- a not-so-clean implementaiton of minimax w/ alpha beta pruning in 473 | -- Haskell :) 474 | maxi :: [Int] -- ^ check order 475 | -> Player -- ^ maximizing player 476 | -> Int -- ^ limit 477 | -> Bounder Double -- ^ alpha 478 | -> Bounder Double -- ^ beta 479 | -> Auto Identity Int BoardOut -- ^ board Auto 480 | -> (Maybe Int, Bounder Double) -- ^ (best move, score) 481 | maxi ms maxP l α0 β0 a | l <= 0 = (Nothing, BIn 0) 482 | | otherwise = foldr f (Nothing, α0) ms 483 | where 484 | f :: Int -> (Maybe Int, Bounder Double) -> (Maybe Int, Bounder Double) 485 | f m' (m, α) = fromMaybe (m, α) $ do 486 | guard . not $ α >= β0 487 | guard . not $ _boFailed bout' 488 | guard $ α'' > α 489 | return (Just m', α'') 490 | where 491 | (bout', a') = stepAuto' a m' 492 | (_, α') = mini ms maxP (l - 1) α β0 a' 493 | α'' = maybe α' (score maxP) $ _boWinner bout' 494 | mini :: [Int] -> Player -> Int -> Bounder Double -> Bounder Double 495 | -> Auto Identity Int BoardOut -> (Maybe Int, Bounder Double) 496 | mini ms maxP l α0 β0 a | l <= 0 = (Nothing, BIn 0) 497 | | otherwise = foldr f (Nothing, β0) ms 498 | where 499 | f m' (m, β) = fromMaybe (m, β) $ do 500 | guard . not $ α0 >= β 501 | guard . not $ _boFailed bout' 502 | guard $ β'' < β 503 | return (Just m', β'') 504 | where 505 | (bout', a') = stepAuto' a m' 506 | (_, β') = maxi ms maxP (l - 1) α0 β a' 507 | β'' = maybe β' (score maxP) $ _boWinner bout' 508 | score cP (Just p) | p == cP = BMax 509 | | otherwise = BMin 510 | score _ Nothing = BIn (-100) 511 | -------------------------------------------------------------------------------- /src/Experimental/Survive.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Arrows #-} 2 | {-# LANGUAGE DeriveFunctor #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE MonadComprehensions #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE TemplateHaskell #-} 9 | {-# LANGUAGE TupleSections #-} 10 | {-# LANGUAGE ViewPatterns #-} 11 | 12 | module Main where 13 | 14 | import Control.Auto 15 | import Control.Auto.Blip 16 | import Control.Auto.Blip.Internal 17 | import Control.Auto.Collection 18 | import Control.Auto.Core 19 | import Control.Auto.Effects 20 | import Control.Auto.Interval 21 | import Control.Auto.Process.Random 22 | import Control.Auto.Run 23 | import Control.Lens 24 | import Control.Monad.Fix 25 | import Control.Monad.Random 26 | import Control.Monad.Reader hiding (forM_, mapM_) 27 | import Control.Monad.Writer hiding ((<>), forM_, mapM_) 28 | import Data.Foldable 29 | import Data.IntMap.Strict (IntMap, Key) 30 | import Data.List (sortBy) 31 | import Data.Map.Strict (Map) 32 | import Data.Maybe 33 | import Data.Ord 34 | import Data.Serialize 35 | import Debug.Trace 36 | import GHC.Generics hiding (to) 37 | import Linear hiding (ei, trace) 38 | import Prelude hiding ((.), id, elem, any, sequence, concatMap, sum, concat, sequence_, mapM_) 39 | import System.Console.ANSI 40 | import System.IO 41 | import Util 42 | import qualified Data.IntMap.Strict as IM 43 | import qualified Data.Map.Strict as M 44 | 45 | 46 | -- | Types for commands, entities, inputs, outputs, etc. 47 | 48 | -- direction 49 | data Dir = DUp | DRight | DDown | DLeft 50 | deriving (Show, Eq, Enum, Ord, Read, Generic) 51 | 52 | -- an action to perform 53 | data Action = Sword 54 | | Bow 55 | | Bomb 56 | | Wall 57 | deriving (Show, Eq, Enum, Ord, Read, Generic) 58 | 59 | -- an item to use 60 | data Item = Potion 61 | deriving (Show, Eq, Enum, Ord, Read, Generic) 62 | 63 | -- something you can pick up 64 | data Pickup = PUArrows 65 | | PUGunpowder 66 | | PUCement 67 | | PUPotion Double 68 | | PUGold Int 69 | deriving (Show, Eq, Ord, Read, Generic) 70 | 71 | -- a command from the outside world/interface 72 | data Cmd = CMove Dir 73 | | CAct Action Dir 74 | | CUse Item 75 | | CNop 76 | deriving (Show, Eq, Ord, Read, Generic) 77 | 78 | -- a way an Entity can respond to the world 79 | data EntResp = ERAtk Double Point -- attack with damage at relative position 80 | | ERShoot Double Int Dir -- shoot with damage and range in direction 81 | | ERBomb Dir -- bomb in direction 82 | | ERBuild Dir -- build in direction 83 | | ERFire Double Int Point -- start a fire with damage and duration in relative position 84 | | ERMonster Char Double Double Point -- create a monster with sprite with health 85 | -- and damage and absolute position 86 | | ERItem Pickup Point -- place an item with pickup at absolute position 87 | | ERGive Key Pickup -- give an entity with key/id a pickup 88 | deriving (Show, Eq, Ord, Read, Generic) 89 | 90 | -- communications an Entity can receive, from another 91 | data EntComm = ECAtk Double -- attack with damage 92 | | ECGive Pickup -- give pickup 93 | deriving (Show, Eq, Ord, Read, Generic) 94 | 95 | -- an entity existing on the map 96 | data Entity = EPlayer 97 | | EBomb 98 | | EWall 99 | | EFire 100 | | EMonster Char 101 | | EItem Pickup 102 | deriving (Show, Eq, Ord, Read, Generic) 103 | 104 | -- input for an Entity auto 105 | data EntityInput = EI { _eiPos :: Point -- new position 106 | , _eiComm :: [(Key, EntComm)] -- communications, from id's 107 | , _eiWorld :: EntityMap -- a map of the world 108 | } deriving (Show, Eq, Ord, Read, Generic) 109 | 110 | -- output for an Entity auto 111 | data EntityOutput a = EO { _eoData :: Maybe a -- extra data; Nothing if none. 112 | , _eoPos :: Point -- position to move from 113 | , _eoMove :: Point -- move 114 | , _eoEntity :: Entity -- the entity 115 | , _eoReact :: Map Entity Double -- "how this would react" when 116 | -- encountering various entities; 117 | -- how much damage it would attack with 118 | , _eoResps :: Maybe [EntResp] -- lists of responses to the world. 119 | -- Nothing if *dead* 120 | } deriving (Show, Eq, Ord, Read, Generic) 121 | 122 | -- output type from the player to the gui/frontend 123 | data PlayerOut = PO { _poMessages :: [OutMessage] -- status messages 124 | , _poHealth :: Double -- health 125 | , _poInventory :: Inventory -- inventory 126 | , _poKills :: Int -- kill count 127 | } deriving (Show, Eq, Ord, Read, Generic) 128 | 129 | -- player inventory, for purpose of PlayerOut rendering. not actaully used 130 | -- for the actual inventory updating of the player itself. 131 | data Inventory = Inv { _invArrows :: Int 132 | , _invGunpowder :: Int 133 | , _invCement :: Int 134 | , _invGold :: Int 135 | } deriving (Show, Eq, Ord, Read, Generic) 136 | 137 | -- a status message to the outside world 138 | data OutMessage = OMAtk Entity Entity Double -- attack from to damage 139 | | OMShot Entity Entity Double -- shot from to damage 140 | | OMMiss Entity -- shot missed by entity 141 | | OMDeath Entity -- entity dies 142 | | OMPickup Entity Pickup -- entity picked up picup 143 | deriving (Show, Eq, Ord, Read, Generic) 144 | 145 | type Point = V2 Int 146 | type GameMap = Map Point [Entity] 147 | type EntityMap = IntMap (Point, Entity) 148 | 149 | instance Serialize EntResp 150 | instance Serialize EntComm 151 | instance Serialize Dir 152 | instance Serialize Pickup 153 | instance Serialize Entity 154 | instance Serialize EntityInput 155 | instance Serialize a => Serialize (EntityOutput a) 156 | instance Serialize Cmd 157 | instance Serialize Item 158 | instance Serialize Action 159 | instance Serialize Inventory 160 | instance Serialize PlayerOut 161 | instance Serialize OutMessage 162 | 163 | instance Semigroup EntityInput where 164 | EI p0 c0 w0 <> EI p1 c1 w1 = EI (p0 `v` p1) (c0 ++ c1) (w0 <> w1) -- watch out, is (<>) right here? 165 | where 166 | v y (V2 (-1) (-1)) = y -- yeah this might not work 167 | v _ y = y 168 | 169 | instance Monoid EntityInput where 170 | mempty = EI (V2 (-1) (-1)) mempty mempty 171 | mappend = (<>) 172 | 173 | instance Semigroup Cmd where 174 | x <> CNop = x 175 | _ <> x = x 176 | 177 | instance Monoid Cmd where 178 | mempty = CNop 179 | mappend x CNop = x 180 | mappend _ x = x 181 | 182 | instance Semigroup PlayerOut where 183 | PO m1 h1 i1 k1 <> PO m2 h2 i2 k2 = PO (m1 ++ m2) (h1 <#> h2) (i1 <> i2) (k1 <#> k2) 184 | where 185 | x <#> (-1) = x 186 | _ <#> y = y 187 | 188 | instance Monoid PlayerOut where 189 | mempty = PO [] (-1) mempty (-1) 190 | mappend = (<>) 191 | 192 | instance Semigroup Inventory where 193 | Inv a1 g1 c1 r1 <> Inv a2 g2 c2 r2 = Inv (a1 <#> a2) (g1 <#> g2) (c1 <#> c2) (r1 <#> r2) 194 | where 195 | x <#> (-1) = x 196 | _ <#> y = y 197 | 198 | instance Monoid Inventory where 199 | mempty = Inv (-1) (-1) (-1) (-1) 200 | mappend = (<>) 201 | 202 | makePrisms ''Cmd 203 | makePrisms ''Pickup 204 | makePrisms ''Item 205 | makePrisms ''EntResp 206 | makePrisms ''EntComm 207 | makePrisms ''Entity 208 | makeLenses ''EntityInput 209 | makeLenses ''EntityOutput 210 | makeLenses ''PlayerOut 211 | makeLenses ''Inventory 212 | 213 | -- | Utility functions 214 | mapSize :: V2 Int 215 | mapSize = V2 70 20 216 | 217 | startPos :: V2 Int 218 | startPos = (`div` 2) <$> mapSize 219 | 220 | initialPO :: PlayerOut 221 | initialPO = PO [] initialHealth initialInv 0 222 | 223 | initialInv :: Inventory 224 | initialInv = Inv 50 10 30 0 225 | 226 | initialHealth :: Double 227 | initialHealth = 50 228 | 229 | dirToV2 :: Dir -> V2 Int 230 | dirToV2 dir = case dir of 231 | DUp -> V2 0 1 232 | DRight -> V2 1 0 233 | DDown -> V2 0 (-1) 234 | DLeft -> V2 (-1) 0 235 | 236 | v2ToDir :: V2 Int -> Maybe Dir 237 | v2ToDir v2 = case v2 of 238 | V2 0 1 -> Just DUp 239 | V2 1 0 -> Just DRight 240 | V2 0 (-1) -> Just DDown 241 | V2 (-1) 0 -> Just DLeft 242 | _ -> Nothing 243 | 244 | -- | Entity `Auto`s 245 | -- 246 | bomb :: Monad m 247 | => Dir 248 | -> Interval m EntityInput (EntityOutput a) 249 | bomb dir = proc ei -> do 250 | -- move constantly 251 | motion <- fromInterval zero . onFor 8 . pure (dirToV2 dir) -< () 252 | 253 | -- damage received 254 | let damage = sumOf (eiComm . traverse . _2 . _ECAtk) ei 255 | 256 | -- trigger: explosion from damage; fuse: explosion from timeout 257 | trigger <- became (<= 0) . sumFrom 2 -< negate damage 258 | fuse <- inB 10 -< 0 259 | 260 | -- explode when either `trigger` or `fuse` emit 261 | let explode = explodes <$ (fuse `mergeL` trigger) 262 | 263 | explosion <- fromBlips [] -< explode 264 | 265 | -- act like the EntityOutput until explosion; then just be on for 1. 266 | before -?> lmap fst (onFor 1) -< (EO Nothing (_eiPos ei) motion EBomb M.empty (Just explosion), explode) 267 | where 268 | explodes = do 269 | x <- [-3..3] 270 | y <- [-3..3] 271 | let r = sqrt (fromIntegral x**2 + fromIntegral y**2) :: Double 272 | guard $ r <= 3 273 | let dur | r < 1 = 2 274 | | r < 2 = 1 275 | | otherwise = 1 276 | str | r < 1 = 16 277 | | r < 2 = 8 278 | | r < 3 = 2 279 | | otherwise = 1 280 | return $ ERFire str dur (V2 x y) 281 | 282 | -- immediately just attack everything and die. 283 | fire :: Monad m 284 | => Double 285 | -> Int 286 | -> Interval m EntityInput (EntityOutput a) 287 | fire str dur = lmap (\ei -> EO Nothing (_eiPos ei) zero EFire M.empty (Just [ERAtk str zero])) (onFor dur) 288 | 289 | -- just sit there and do nothing. 290 | wall :: Monad m 291 | => Auto m EntityInput (EntityOutput a) 292 | wall = arr $ \ei -> EO Nothing (_eiPos ei) zero EWall M.empty (Just []) 293 | 294 | -- sit there and do nothing, but when the player steps on you, send them an 295 | -- `ERGive` response. 296 | itemPu :: Monad m => Pickup -> Point -> Interval m EntityInput (EntityOutput (Double, a)) 297 | itemPu pu p0 = proc ei -> do 298 | pos <- onFor 1 . pure p0 <|!> id -< _eiPos ei -- ignore first ei 299 | let pPos = preview (eiWorld . ix (-1) . _1) ei 300 | 301 | pickedB <- emitOn (uncurry (==)) -< (Just pos, pPos) 302 | picked <- fromBlips [] -< [ERGive (-1) pu] <$ pickedB 303 | 304 | let eOut = EO Nothing pos zero (EItem pu) M.empty (Just picked) 305 | 306 | naturalDeath <- inB 200 -< () 307 | 308 | before -?> dead -< (eOut, (() <$ pickedB) <> naturalDeath) 309 | where 310 | dead = lmap fst (onFor 1) -?> lmap (set eoResps Nothing . fst) (onFor 1) 311 | 312 | -- take an 'Auto' that never dies, and imbues it with health and death. 313 | -- teaches an 'Auto' how to die. 314 | withHealth :: MonadWriter ([OutMessage], Sum Int) m 315 | => Double 316 | -> Auto m EntityInput (EntityOutput (Double, a)) 317 | -> Interval m EntityInput (EntityOutput (Double, a)) 318 | withHealth h0 entA = proc ei -> do 319 | eOut <- entA -< ei 320 | let damage = sumOf (eiComm . traverse . _2 . _ECAtk) ei 321 | 322 | health <- sumFrom h0 -< negate damage 323 | 324 | -- set the EntityOutput data field to be its health 325 | let eOut' = set (eoData . _Just . _1) (max 0 health) eOut 326 | 327 | die <- became (<= 0) -< health 328 | 329 | -- send a mesage if a monster dies 330 | if has (eoEntity . _EMonster) eOut 331 | then arrMB tell -< ([OMDeath (_eoEntity eOut)], 1) <$ die 332 | else never -< () 333 | 334 | -- send a message if the player dies 335 | if has (eoEntity . _EPlayer) eOut 336 | then arrMB (tell . (,mempty)) -< [OMDeath (_eoEntity eOut)] <$ die 337 | else never -< () 338 | 339 | before -?> dead -< (eOut' , die) 340 | where 341 | dead = lmap (set eoResps Nothing . fst) (onFor 1) 342 | 343 | -- the player. move around, send out attacks, pick up recharges, drain 344 | -- inventory.... 345 | player :: MonadReader Cmd m -- environment is the current command 346 | => Auto m EntityInput (EntityOutput (Double, Inventory)) 347 | player = proc (EI p comm _) -> do 348 | inp <- effect ask -< () 349 | move <- fromBlips zero 350 | . modifyBlips dirToV2 351 | . emitJusts (preview _CMove) -< inp 352 | 353 | resps <- fromBlipsWith [] (:[]) 354 | . modifyBlips toResp 355 | . emitJusts (preview _CAct) -< inp 356 | 357 | arrowUsage <- emitJusts $ preview (traverse . _ERShoot) -< resps 358 | gunpowderUsage <- emitJusts $ preview (traverse . _ERBomb) -< resps 359 | cementUsage <- emitJusts $ preview (traverse . _ERBuild) -< resps 360 | 361 | getArrow <- emitOn (> 0) -< length . toListOf (traverse . _2 . _ECGive . _PUArrows) $ comm 362 | getGunpowder <- emitOn (> 0) -< length . toListOf (traverse . _2 . _ECGive . _PUGunpowder) $ comm 363 | getCement <- emitOn (> 0) -< length . toListOf (traverse . _2 . _ECGive . _PUCement) $ comm 364 | 365 | arrows <- scanPos (_invArrows initialInv) -< merge (+) ((-1) <$ arrowUsage) (15 <$ getArrow) 366 | gunpowder <- scanPos (_invGunpowder initialInv) -< merge (+) ((-1) <$ gunpowderUsage) ( 5 <$ getGunpowder) 367 | cement <- scanPos (_invCement initialInv) -< merge (+) ((-1) <$ cementUsage) (15 <$ getCement) 368 | 369 | gold <- sumFrom 0 -< sumOf (traverse . _2 . _ECGive . _PUGold) comm 370 | 371 | let resps' = filter (enough arrows gunpowder cement) resps 372 | 373 | id -< EO (Just (initialHealth, Inv arrows gunpowder cement gold)) p move EPlayer atkMap (Just resps') 374 | where 375 | toResp :: (Action, Dir) -> EntResp 376 | toResp (u,d) = case u of 377 | Sword -> ERAtk 4 (dirToV2 d) 378 | Bow -> ERShoot 1 15 d 379 | Bomb -> ERBomb d 380 | Wall -> ERBuild d 381 | atkMap = M.fromList . map (,4) $ [EWall, EMonster 'Z', EBomb] 382 | scanPos = scanB (\x y -> max 0 (x + y)) 383 | enough ar gp cm resp = case resp of 384 | ERAtk {} -> True 385 | ERShoot {} -> ar > 0 386 | ERBomb {} -> gp > 0 387 | ERBuild {} -> cm > 0 388 | _ -> True 389 | 390 | -- move towards the player if it exists, or move around randomly if not. 391 | monster :: MonadRandom m 392 | => Char 393 | -> Double 394 | -> Auto m EntityInput (EntityOutput a) 395 | monster c damg = proc ei -> do 396 | let pPos = ei ^? eiWorld . traverse . filtered (has (_2 . _EPlayer)) . _1 397 | mPos = _eiPos ei 398 | delta = (^-^ mPos) <$> pPos 399 | moves = flip fmap delta $ \(V2 dx dy) -> 400 | let adx = abs dx 401 | ady = abs dy 402 | in (V2 (signum dx) 0 <$ guard (adx /= 0)) 403 | <|> (V2 0 (signum dy) <$ guard (ady /= 0)) 404 | 405 | move <- during (arrM uniform) -< moves 406 | wander <- effect (dirToV2 `liftM` uniform [DUp ..]) -< () 407 | 408 | let move' = fromMaybe wander move 409 | 410 | id -< EO Nothing mPos move' (EMonster c) atkMap (Just []) 411 | where 412 | atkMap = M.fromList . map (,damg) $ [EPlayer, EWall, EBomb] 413 | 414 | -- the main game loop 415 | game :: MonadFix m 416 | => StdGen 417 | -> Auto m Cmd (PlayerOut, GameMap) 418 | game g = proc inp -> do 419 | -- run game', get the outputs, , count kills, save the last output, 420 | -- output to the client. 421 | (((eo, _), gm), (msgs, newKills)) <- game' -< inp 422 | kills <- sumFrom 0 -< getSum newKills 423 | lastEoDat <- holdJusts 424 | <|!> pure (initialHealth, initialInv) -< _eoData =<< eo 425 | let (hlth, inv) = lastEoDat 426 | let po = PO msgs hlth inv kills 427 | id -< (po, gm) 428 | where 429 | -- run the Writer and the Random over 'bracketA playerA worldA' 430 | -- "bracketA" runs player, then world, then player, so that the player 431 | -- gets a chance to "clean up". 432 | -- bracketA :: Auto m (Either a b) c -> Auto m c b -> Auto m a c runs 433 | -- the first on the `a` Right input, feeds the `c` into the second, 434 | -- runs the `b` output onto the first's Left channel, and outputs the 435 | -- final `c`. 436 | game' = runWriterA (sealRandomStd (bracketA playerA worldA) g) 437 | playerA :: (MonadFix m, MonadWriter ([OutMessage], Sum Int) m) 438 | => Auto m (Either Cmd EntityInput) 439 | ( ( Maybe (EntityOutput (Double, Inventory)) 440 | , IntMap EntityInput 441 | ) 442 | , GameMap 443 | ) 444 | -- manage the player input and wrapping the `player` Auto 445 | playerA = proc inp -> do 446 | -- last received world is the last world received from `Right` 447 | lastWorld <- holdWith IM.empty . emitJusts (preview (_Right . eiWorld)) -< inp 448 | rec lastPos <- delay startPos -< currPos 449 | -- new entity input for player 450 | let ei = set eiPos lastPos . either (const mempty) id $ inp 451 | -- run it through player', with the input 452 | pEo <- player' -< (ei, either id (const CNop) inp) 453 | -- generate the resulting entity inputs for everyone else, and 454 | -- messages 455 | let (pEis, msgs) = IM.mapAccumWithKey (mkEntIns lastWorld) IM.empty $ maybe IM.empty (IM.singleton (-1)) pEo 456 | 457 | -- keep the current position; move when the player intputs ask 458 | -- the player to move 459 | currPos <- holdWith startPos . emitJusts (preview (ix (-1) . eiPos)) -< pEis 460 | 461 | -- log the messages; messages are ([OutMessage], Sum Int) (kill count) 462 | arrM (tell . (,mempty)) -< toListOf (traverse . traverse) msgs 463 | 464 | let outEo = set (_Just . eoPos) currPos pEo 465 | outEi = IM.delete (-1) pEis 466 | outGm = either (const M.empty) (mkGMap lastPos . _eiWorld) inp 467 | 468 | id -< ((outEo, outEi), outGm) 469 | where 470 | -- imbue position, health, and take an extra parameter as the 471 | -- Reader environment 472 | player' = runReaderA . booster startPos . withHealth initialHealth $ player 473 | mkGMap p = M.fromListWith (<>) 474 | . IM.elems 475 | . (fmap . second) (:[]) 476 | . IM.insert (-1) (p, EPlayer) 477 | 478 | -- the rest of the world 479 | worldA :: (MonadFix m, MonadWriter ([OutMessage], Sum Int) m, MonadRandom m) 480 | => Auto m ( ( Maybe (EntityOutput (Double, a)) 481 | , IntMap EntityInput 482 | ), GameMap 483 | ) 484 | EntityInput 485 | worldA = proc ((pEo, pEis), _) -> do 486 | -- make things... monsters and items 487 | mkMonsters <- makeMonsters 25 -< () 488 | mkItems <- makeItems 15 -< () 489 | 490 | -- run all of the entities on all of the inputs, using dynMapF 491 | rec entOuts <- dynMapF makeEntity mempty -< ( -- inputs from player and inputs from entities 492 | IM.unionWith (<>) pEis entInsD' 493 | -- make-new-entity events from everywhere 494 | , newEntsBAll <> mkMonsters <> mkItems 495 | ) 496 | 497 | -- only alive 498 | let entOutsAlive = IM.filter (has (eoResps . _Just)) entOuts 499 | -- alive + player entity output 500 | entOutsFull = maybe entOutsAlive (\po -> IM.insert (-1) po entOutsAlive) pEo 501 | -- map of all locations and entities 502 | entMap = (_eoPos &&& _eoEntity) <$> entOutsFull 503 | -- generate new entity inputs from the entity outputs 504 | (entIns,msgs) = IM.mapAccumWithKey (mkEntIns entMap) IM.empty entOutsAlive 505 | -- update entity maps 506 | entMap' = maybe id (\po -> IM.insert (-1) (_eoPos po, EPlayer)) pEo 507 | . flip IM.mapMaybeWithKey entIns $ \k ei -> do 508 | eo <- IM.lookup k entOutsFull 509 | return (_eiPos ei, _eoEntity eo) 510 | entIns' = flip IM.mapWithKey entIns $ \k -> set eiWorld (IM.delete k entMap') 511 | 512 | -- new entities, to send in as blip stream 513 | newEnts = toList entOutsAlive >>= \(EO _ p _ _ _ ers) -> maybe [] (map (p,)) ers 514 | 515 | -- EntResps from player 516 | plrEResps = toListOf (_Just . eoResps . _Just . traverse) pEo 517 | plrEResps' = case pEo of 518 | Nothing -> [] 519 | Just po -> (_eoPos po,) <$> plrEResps 520 | 521 | -- emit all non-empty newEnts, from "last cycle" 522 | newEntsB <- lagBlips . emitOn (not . null) -< newEnts 523 | -- all entity inputs from last cycle, to send into `entOuts` 524 | entInsD <- delay IM.empty -< entIns' 525 | -- add in the player entity to the world maps 526 | let entInsD' = case pEo of 527 | Just po -> over (traverse . eiWorld) (IM.insert (-1) (_eoPos po, EPlayer)) entInsD 528 | Nothing -> entInsD 529 | 530 | playerB <- emitOn (not . null) -< plrEResps' 531 | 532 | let newEntsBAll = newEntsB <> playerB 533 | 534 | -- write messages to log; messages are ([OutMessage], Sum Int) (kill count) 535 | arrM (tell . (,mempty)) -< toListOf (traverse . traverse) msgs 536 | 537 | id -< set eiWorld (IM.delete (-1) entMap') . IM.findWithDefault mempty (-1) $ entIns' 538 | where 539 | makeMonsters :: MonadRandom m => Int -> Auto m a (Blip [(Point, EntResp)]) 540 | makeMonsters n = onFor 500 . perBlip makeMonster . every n 541 | --> makeMonsters ((n * 3) `div` 4) 542 | makeMonster :: MonadRandom m => Auto m a [(Point, EntResp)] 543 | makeMonster = liftA2 (\x y -> [(zero, ERMonster 'Z' 5 5 (shift (V2 x y)))]) 544 | (effect (getRandomR (0, view _x mapSize `div` 2))) 545 | (effect (getRandomR (0, view _y mapSize `div` 2))) 546 | where 547 | shift = liftA2 (\m x -> (x - (m `div` 4)) `mod` m) mapSize 548 | 549 | makeItems :: MonadRandom m => Double -> Auto m a (Blip [(Point, EntResp)]) 550 | makeItems r = perBlip makeItem . bernoulliMR (1/r) 551 | where 552 | makeItem = liftA3 (\x y i -> [(zero, ERItem i (shift (V2 x y)))]) 553 | (effect (getRandomR (0, 2 * view _x mapSize `div` 3))) 554 | (effect (getRandomR (0, 2 * view _y mapSize `div` 3))) 555 | (effect randomItem) 556 | shift = liftA2 (\m x -> (x + (m `div` 6))) mapSize 557 | randomItem = do 558 | x <- fromList [ (PUArrows, 1.5) 559 | , (PUGunpowder, 1) 560 | , (PUCement, 1) 561 | , (PUPotion 0, 1) 562 | , (PUGold 0, 1) 563 | ] 564 | case x of 565 | PUGold _ -> PUGold `liftM` getRandomR (5,15) 566 | PUPotion _ -> PUPotion `liftM` getRandomR (10,40) 567 | _ -> return x 568 | 569 | -- start off at give position 570 | booster p0 a = (onFor 1 . arr (set (_Just . eoPos) p0) --> id) . a 571 | 572 | -- generating entity inputs from entity outputs of last round. kinda 573 | -- complicated, but this is the beef of the game logic, having every 574 | -- entity communicate with every other one. run using 575 | -- `IM.mapAccumWithKey` 576 | mkEntIns :: EntityMap -- world map 577 | -> IntMap EntityInput -- current "output" map, in-progress 578 | -> Key -- key of this processed entity 579 | -> EntityOutput a -- entity output of this processed entity 580 | -> (IntMap EntityInput, [OutMessage]) -- updated "output" map, and also communications 581 | mkEntIns em eis k (EO _ pos0 mv e react (Just resps)) = (IM.insertWith (<>) k res withGives, messages) 582 | where 583 | em' = IM.delete k em 584 | pos1 = pos0 ^+^ mv 585 | oldCols = IM.mapMaybe (\(p,e') -> e' <$ guard (p == pos1)) em' 586 | newCols = flip IM.mapMaybeWithKey eis $ \k' ei -> do 587 | guard (_eiPos ei == pos1) 588 | snd <$> IM.lookup k' em' 589 | allCols = oldCols <> newCols 590 | pos2 | any isBlocking allCols = pos0 591 | | otherwise = clamp pos1 -- could be short circuited here, really... 592 | colAtks = flip IM.mapMaybe allCols $ \e' -> do 593 | d <- M.lookup e' react 594 | return (over eiComm ((k, ECAtk d):) mempty, [OMAtk e e' d]) 595 | respAtks = IM.unionsWith (<>) . flip mapMaybe resps $ \r -> 596 | case r of 597 | ERAtk a _ -> 598 | let placed = place pos2 r 599 | oldHits = snd <$> IM.filter (\(p,_) -> placed == p) em' 600 | newHits = flip IM.mapMaybeWithKey eis $ \k' ei -> do 601 | guard (placed == _eiPos ei) 602 | snd <$> IM.lookup k' em 603 | allHits = oldHits <> newHits 604 | in Just $ (\e' -> (set eiComm [(k, ECAtk a)] mempty, [OMAtk e e' a])) <$> allHits 605 | ERShoot a rg d -> -- TODO: drop when miss 606 | let rg' = fromIntegral rg 607 | oldHits = flip IM.mapMaybe em' $ \(p, e') -> do 608 | guard $ arrowHit e' 609 | dst <- aligned pos2 p d 610 | dst <$ guard (dst <= rg') 611 | newHits = flip IM.mapMaybeWithKey eis $ \k' ei -> do 612 | guard $ arrowHit (snd (em IM.! k')) 613 | dst <- aligned pos2 (_eiPos ei) d 614 | dst <$ guard (dst <= rg') 615 | allHits = oldHits <> newHits 616 | minHit = fst . minimumBy (comparing snd) $ IM.toList allHits 617 | in Just $ if IM.null allHits 618 | then IM.singleton k (mempty, [OMMiss e]) 619 | else IM.singleton minHit (set eiComm [(k, ECAtk a)] mempty, [OMShot e (snd (em IM.! minHit)) a]) 620 | _ -> 621 | Nothing 622 | 623 | respGives = IM.unionsWith (<>) . flip mapMaybe resps $ \r -> 624 | case r of 625 | ERGive k' pu -> Just $ IM.singleton k' (set eiComm [(k, ECGive pu)] mempty, [OMPickup (snd (em IM.! k')) pu]) 626 | _ -> Nothing 627 | 628 | allAtks = colAtks <> respAtks 629 | messages = toListOf (traverse . traverse) 630 | $ IM.unionWith (<>) (snd <$> allAtks) (snd <$> respGives) 631 | 632 | withAtks = IM.unionWith (<>) (fst <$> IM.delete k allAtks) eis 633 | withGives = IM.unionWith (<>) (fst <$> respGives) withAtks 634 | res = EI pos2 [] em' 635 | isBlocking ent = case ent of 636 | EPlayer -> True 637 | EWall -> True 638 | EBomb -> True 639 | EFire -> False 640 | EMonster _ -> True 641 | EItem _ -> False 642 | aligned :: Point -> Point -> Dir -> Maybe Double 643 | aligned p0 p1 dir = norm r <$ guard (abs (dotted - 1) < 0.001) 644 | where 645 | r = fmap fromIntegral (p1 - p0) :: V2 Double 646 | rUnit = normalize r 647 | dotted = rUnit `dot` fmap fromIntegral (dirToV2 dir) 648 | arrowHit :: Entity -> Bool 649 | arrowHit ent = case ent of 650 | EPlayer -> True 651 | EWall -> False 652 | EBomb -> True 653 | EFire -> False 654 | EMonster _ -> True 655 | EItem _ -> False 656 | mkEntIns _ eis _ _ = (eis, []) 657 | clamp = liftA3 (\mn mx -> max mn . min mx) (V2 0 0) mapSize 658 | 659 | -- make entity from EntResp 660 | makeEntity :: (MonadRandom m, MonadWriter ([OutMessage], Sum Int) m) 661 | => (Point, EntResp) 662 | -> Interval m EntityInput (EntityOutput (Double, a)) 663 | makeEntity (p, er) = case er of 664 | ERBomb dir -> booster placed $ bomb dir 665 | ERBuild {} -> booster placed . withHealth 50 $ wall 666 | ERMonster c h d _ -> booster placed . withHealth h $ monster c d 667 | ERFire s d _ -> booster placed $ fire s d 668 | ERItem pu pos -> itemPu pu pos 669 | ERAtk {} -> off 670 | ERShoot {} -> off 671 | ERGive {} -> off 672 | where 673 | placed = place p er 674 | 675 | -- where to place entity, given initial point and resp? 676 | place :: Point -> EntResp -> Point 677 | place p er = case er of 678 | ERAtk _ disp -> p ^+^ disp 679 | ERBomb {} -> p 680 | ERBuild dir -> p ^+^ dirToV2 dir 681 | ERShoot _ _ dir -> p ^+^ dirToV2 dir 682 | ERFire _ _ d -> p ^+^ d 683 | ERMonster _ _ _ p' -> p' 684 | ERItem _ p' -> p' 685 | ERGive {} -> zero 686 | 687 | 688 | -- handle command stream 689 | handleCmd :: (Serialize b, Monoid b, Monad m) 690 | => Auto m Cmd b 691 | -> Auto m (Maybe Cmd) b 692 | handleCmd a0 = holdWith mempty . perBlip a0 . onJusts 693 | 694 | -- render the board 695 | renderBoard :: (PlayerOut, GameMap) -> String 696 | renderBoard (PO msgs ph (Inv ar gp cm gd) k, mp) = 697 | unlines . concat $ [ map renderOM msgs 698 | , "You dead!" <$ guard (ph <= 0) 699 | , ["[1] Sword\t[2] Bow (" ++ show ar ++ ")\t[3] Bomb (" ++ show gp ++ ")\t[4] Wall (" ++ show cm ++ ")"] 700 | , mapOut 701 | , ["Health: " ++ show (round ph :: Int) ++ "\tKills: " ++ show k ++ "\tGold: " ++ show gd] 702 | ] 703 | where 704 | renderOM om = case om of 705 | OMAtk e1 e2 d -> [entChr e1] ++ " attacked " ++ [entChr e2] ++ " for " ++ show d ++ " HP" 706 | OMShot e1 e2 d -> [entChr e1] ++ " shot " ++ [entChr e2] ++ " for " ++ show d ++ " HP" 707 | OMMiss e1 -> "Shot from " ++ [entChr e1] ++ " missed!" 708 | OMDeath e1 -> [entChr e1] ++ " died" 709 | OMPickup e1 pu -> [entChr e1] ++ " picked up " ++ showPu pu 710 | mapOut = reverse [[ charAt x y | x <- [0..xMax] ] | y <- [0..yMax]] 711 | charAt x y = fromMaybe '.' $ do 712 | es <- M.lookup (V2 x y) mp 713 | let es' | ph > 0 = es 714 | | otherwise = filter (/= EPlayer) es 715 | fmap entChr . listToMaybe . sortBy (comparing entPri) $ es' 716 | xMax = view _x mapSize 717 | yMax = view _y mapSize 718 | entChr e = case e of 719 | EPlayer -> '@' 720 | EBomb -> 'o' 721 | EWall -> '#' 722 | EFire -> '"' 723 | EMonster c -> c 724 | EItem pu -> puChr pu 725 | entPri e = case e of 726 | EPlayer -> 0 :: Int 727 | EFire -> 1 728 | EMonster _ -> 2 729 | EBomb -> 4 730 | EItem _ -> 5 731 | EWall -> 6 732 | puChr pu = case pu of 733 | PUArrows -> '>' 734 | PUGunpowder -> '%' 735 | PUCement -> '=' 736 | PUPotion _ -> '?' 737 | PUGold _ -> '*' 738 | showPu pu = case pu of 739 | PUArrows -> "arrows" 740 | PUGunpowder -> "gunpowder" 741 | PUCement -> "cement" 742 | PUPotion _ -> "an unimplemented potion" 743 | PUGold amt -> show amt ++ " gold" 744 | 745 | 746 | -- primitive command parser 747 | parseCmd :: Auto m Char (Blip (Maybe Cmd)) 748 | parseCmd = go Nothing 749 | where 750 | go Nothing = mkAuto_ $ \x -> case x of 751 | 'h' -> (Blip (Just (CMove DLeft )) , go Nothing ) 752 | 'j' -> (Blip (Just (CMove DDown )) , go Nothing ) 753 | 'k' -> (Blip (Just (CMove DUp )) , go Nothing ) 754 | 'l' -> (Blip (Just (CMove DRight)) , go Nothing ) 755 | '5' -> (Blip (Just (CUse Potion )) , go Nothing ) 756 | ' ' -> (Blip (Just CNop) , go Nothing ) 757 | '1' -> (NoBlip , go (Just Sword)) 758 | '2' -> (NoBlip , go (Just Bow )) 759 | '3' -> (NoBlip , go (Just Bomb )) 760 | '4' -> (NoBlip , go (Just Wall )) 761 | _ -> (Blip Nothing , go Nothing ) 762 | go (Just u) = mkAuto_ $ \x -> case x of 763 | 'h' -> (Blip (Just (CAct u DLeft )), go Nothing ) 764 | 'j' -> (Blip (Just (CAct u DDown )), go Nothing ) 765 | 'k' -> (Blip (Just (CAct u DUp )), go Nothing ) 766 | 'l' -> (Blip (Just (CAct u DRight)), go Nothing ) 767 | _ -> (Blip Nothing , go Nothing ) 768 | 769 | main :: IO () 770 | main = do 771 | g <- newStdGen 772 | hSetBuffering stdin NoBuffering 773 | renderStdout (initialPO, M.singleton startPos [EPlayer]) 774 | _ <- runM generalize getChar process $ hold 775 | . perBlip (handleCmd (game g)) 776 | . parseCmd 777 | return () 778 | where 779 | renderStdout mp = do 780 | clearScreen 781 | putStrLn "" 782 | putStrLn (renderBoard mp) 783 | process mp' = do 784 | mapM_ renderStdout mp' 785 | Just <$> getChar 786 | 787 | -- turn Identity into IO 788 | generalize :: Monad m => Identity a -> m a 789 | generalize = return . runIdentity 790 | --------------------------------------------------------------------------------