Data commit

Task/Snake/Haskell/snake-1.hs

@@ -0,0 +1,100 @@
+{-# LANGUAGE TemplateHaskell #-}
+import Control.Monad.Random (getRandomRs)
+import Graphics.Gloss.Interface.Pure.Game
+import Lens.Micro ((%~), (^.), (&), set)
+import Lens.Micro.TH (makeLenses)
+
+--------------------------------------------------------------------------------
+-- all data types
+
+data Snake = Snake { _body :: [Point], _direction :: Point }
+makeLenses ''Snake
+
+data World = World { _snake :: Snake , _food :: [Point]
+                   , _score :: Int , _maxScore :: Int }
+makeLenses ''World
+
+--------------------------------------------------------------------------------
+-- everything snake can do
+
+moves (Snake b d) = Snake (step b d : init b) d
+eats  (Snake b d) = Snake (step b d : b) d
+bites (Snake b _) = any (== head b)
+step ((x,y):_) (a,b) = (x+a, y+b)
+
+turn (x',y') (Snake b (x,y)) | (x+x',y+y') == (0,0)  = Snake b (x,y)
+                             | otherwise             = Snake b (x',y')
+
+--------------------------------------------------------------------------------
+-- all randomness
+
+createWorld = do xs <- map fromIntegral <$> getRandomRs (2, 38 :: Int)
+                 ys <- map fromIntegral <$> getRandomRs (2, 38 :: Int)
+                 return (Ok, World snake (zip xs ys) 0 0)
+                 where
+                   snake = Snake [(20, 20)] (1,0)
+
+-------------------------------------------------------------------------------
+-- A tyny DSL for declarative description of business logic
+
+data Status = Ok | Fail | Stop
+
+continue = \x -> (Ok, x)
+stop     = \x -> (Stop, x)
+f >>> g  = \x -> case f x of { (Ok, y) -> g y; b -> b }    -- chain composition
+f <|> g  = \x -> case f x of { (Fail, _) -> g x; b -> b }  -- alternative
+p ==> f  = \x -> if p x then f x else (Fail, x)            -- condition
+l .& f   = continue . (l %~ f)                             -- modification
+l .= y   = continue . set l y                              -- setting
+
+--------------------------------------------------------------------------------
+-- all business logic
+
+updateWorld _ =  id >>> (snakeEats <|> snakeMoves)
+  where
+    snakeEats  = (snakeFindsFood ==> (snake .& eats)) >>>
+                 (score .& (+1)) >>> (food .& tail)
+
+    snakeMoves = (snakeBitesTail ==> stop) <|>
+                 (snakeHitsWall ==> stop) <|>
+                 (snake .& moves)
+
+    snakeFindsFood w = (w^.snake & moves) `bites` (w^.food & take 1)
+    snakeBitesTail w = (w^.snake) `bites` (w^.snake.body & tail)
+    snakeHitsWall w  = (w^.snake.body) & head & isOutside
+    isOutside (x,y) = or [x <= 0, 40 <= x, y <= 0, 40 <= y]
+
+--------------------------------------------------------------------------------
+-- all event handing
+
+handleEvents e (s,w) = f w
+  where f = case s of
+          Ok -> case e of
+            EventKey (SpecialKey k) _ _ _ -> case k of
+              KeyRight -> snake .& turn (1,0)
+              KeyLeft  -> snake .& turn (-1,0)
+              KeyUp    -> snake .& turn (0,1)
+              KeyDown  -> snake .& turn (0,-1)
+              _-> continue
+            _-> continue
+          _-> \w -> w & ((snake.body) .= [(20,20)]) >>>
+                         (maxScore .& max (w^.score)) >>> (score .= 0)
+
+--------------------------------------------------------------------------------
+-- all graphics
+
+renderWorld (s, w) = pictures [frame, color c drawSnake, drawFood, showScore]
+  where c = case s of { Ok -> orange; _-> red }
+        drawSnake = foldMap (rectangleSolid 10 10 `at`) (w^.snake.body)
+        drawFood = color blue $ circleSolid 5 `at` (w^.food & head)
+        frame = color black $ rectangleWire 400 400
+        showScore = color orange $ scale 0.2 0.2 $ txt `at` (-80,130)
+        txt = Text $ mconcat ["Score: ", w^.score & show
+                             ,"   Maximal score: ", w^.maxScore & show]
+        at p (x,y) = Translate (10*x-200) (10*y-200) p
+
+--------------------------------------------------------------------------------
+
+main = do world <- createWorld
+          play inW white 7 world renderWorld handleEvents updateWorld
+  where inW = InWindow "The Snake" (400, 400) (10, 10)

Task/Snake/Haskell/snake-2.hs

@@ -0,0 +1 @@
+updateWorld _ =  id >>> snakeSeeksFood >>> (snakeEats <|> snakeMoves)

Task/Snake/Haskell/snake-3.hs

@@ -0,0 +1,13 @@
+    snakeSeeksFood w = w & snake .& turns optimalDirection
+      where
+        optimalDirection = minimumBy (comparing distanceToFood) safeTurns
+
+        safeTurns = filter safe [(x,y),(-y,x),(y,-x)] `ifEmpty` [(x,y)]
+          where (x,y) = w^.snake.direction
+                safe d = let w'' = w & snake %~ moves . turns d
+                         in not (snakeBitesTail w'' || snakeHitsWall w'')
+                lst `ifEmpty` x = if null lst then x else lst
+
+        distanceToFood d = let (a,b) = w^.snake & turns d & moves & (^.body) & head
+                               (x,y) = w^.food & head
+                           in (a-x)^2 + (b-y)^2