Puppies.hs

{-# LANGUAGE ViewPatterns #-}
module Main where

import Control.Applicative
import Control.Concurrent
import System.Console.ANSI
import System.IO
-- import Test.HUnit -- Soon

data Direction = Leftwards | Rightwards deriving (Show, Eq, Bounded, Enum)
data Three = One | Two | Three deriving (Show, Eq, Bounded, Enum)

data PuppyState = Start
                | Up | StartUp
                | Pulse (Maybe Direction) (Maybe (Direction, Three))
                | Running 
                | EndPoint deriving (Show, Eq)

-- Classification of states

upish EndPoint = True
upish Up       = True
upish Running  = True
upish StartUp  = True
upish _        = False

terminalState Running  = True
terminalState EndPoint = True
terminalState _        = False

reflective EndPoint = True
reflective Up       = True
reflective _        = False


-- Extractors

fastPulse (Pulse fast slow) = fast
fastPulse _ = Nothing

slowPulse (Pulse fast slow) = slow
slowPulse _ = Nothing

slowPulseHeading = (liftA fst) . slowPulse

heading dir state = extractMaybeBool $ liftA2 (||) 
                    ((== dir) <$> fastPulse state)
                    ((== dir) <$> slowPulseHeading state)

slowPulseReady (Pulse _ (Just (dir,One))) = Just dir
slowPulseReady _ = Nothing

extractMaybeBool = maybe False id

maybeFirst (Just x) _ = Just x
maybeFirst _        y = y

-- State transition helpers

decrementSlowPulse Nothing = Nothing
decrementSlowPulse (Just (d,   One)) = Nothing
decrementSlowPulse (Just (d,   Two)) = Just (d, One)
decrementSlowPulse (Just (d, Three)) = Just (d, Two)


-- 
computePulse extract left self right
    = if fromLeft  then Just Rightwards else
      if fromRight then Just Leftwards else 
      if bounceLeft then Just Leftwards else
      if bounceRight then Just Rightwards else Nothing
    where fromLeft  = extractMaybeBool $ (== Rightwards) <$> extract left
          fromRight = extractMaybeBool $ (== Leftwards ) <$> extract right
          bounceLeft    = (extractMaybeBool $ (== Rightwards) <$> extract self)
                      && reflective right
          bounceRight    = (extractMaybeBool $ (== Leftwards) <$> extract self)
                      && reflective left

next Start    Start            Start
    = Start
next Start    Start            EndPoint
    = Start
next left     self             right
    | upish left && upish self && upish right
    = Running
next Up      (Pulse _ _)       Up
    = Up
next _        StartUp          _
    = Up
next _        Up               _
    = Up
next EndPoint Start            _  -- Inital move
    = Pulse (Just Rightwards) (Just (Rightwards, Three))
next StartUp  self            _
    = Pulse (Just Rightwards) (Just (Rightwards, Three))
next _        self            StartUp
    = Pulse (Just Leftwards) (Just (Leftwards, Three))
next left     self             right 
    |  heading Rightwards left && heading Leftwards self
    || heading Leftwards right && heading Rightwards self
    = StartUp
next leftDog  self             rightDog
    = fixup $ Pulse 
                (computePulse fastPulse leftDog self rightDog)
                (maybeFirst
                  (decrementSlowPulse (slowPulse self))
                  (maybe Nothing
                     (\d -> Just (d,Three)) $
                       (computePulse slowPulseReady leftDog self rightDog)))

-- Checks if we should transition to StartUp
fixup (Pulse (Just Leftwards) (Just (Rightwards,_))) = StartUp
fixup (Pulse (Just Rightwards) (Just (Leftwards,_))) = StartUp
fixup (Pulse (Just _) (Just _)) = StartUp
fixup state = state


-- Code for running it

initState n = EndPoint : iterateN n (Start :) [EndPoint]

wideMap f lst = EndPoint : zipWith3 f lst (tail lst) (tail $ tail lst) ++ [EndPoint]

printDogs dogs = putStr $ concatMap stringDog dogs


simulate 0 dogs = return ()
simulate n dogs | all terminalState dogs = printDogs dogs >> putStr "\n"
simulate n dogs = do printDogs dogs
                     putStr "\n"
                     simulate (n-1) $ wideMap next dogs

simulateClear 0 dogs = return ()
simulateClear n dogs | all terminalState dogs = 
    do setCursorColumn 0
       printDogs dogs
       putStr "\n"
simulateClear n dogs = do clearLine
                          setCursorColumn 0
                          printDogs dogs
                          threadDelay 200000  
                          simulateClear (n-1) $ wideMap next dogs

start = simulate 50 (initState 7)

main = do hSetBuffering stdout NoBuffering
          simulateClear 900 (initState 15)

iterateN 0 f a = a
iterateN n f a = f $ iterateN (pred n) f a


-- Code for printing

stringDirection Leftwards = '<'
stringDirection Rightwards = '>'

stringCount One = '1'
stringCount Two = '2'
stringCount Three = '3'

stringSlow = maybe ' ' stringDirection

stringFast (Just (dir, count)) = [stringCount count, stringDirection dir]
stringFast Nothing = "  "

colorize color s = setSGRCode [SetColor Foreground Dull color] ++ s

stringDog Start = colorize Green " s   "
stringDog Up    = colorize Blue " u   "
stringDog (Pulse slow fast) = colorize Green [' ', 'p'] 
            ++ colorize Red [stringSlow slow] 
            ++ colorize Cyan (stringFast fast)
stringDog StartUp = colorize Blue " U   "
stringDog EndPoint = colorize Black "E"
stringDog Running = colorize Green " R   "


-- Concrete example of states for testing

stateAboutToTick = Pulse Nothing (Just (Rightwards, One))