Refactor ai

src/Dodge/AIs.hs

@@ -1,17 +1,15 @@
 module Dodge.AIs 
-    ( basicShooterAI
+    ( twitchMissAI
-    , twitchMissAI
     , launcherAI
     , chargeAI
     , sniperAI
     , dodgeAI
-    , miniAI
     , spawnerAI
     ) where
 import Dodge.Creature.Stance.Data
 import Dodge.Creature.State.Data
 import Dodge.Creature.Impulse.Data
-import Dodge.Data
+import Dodge.Data hiding (Action (..), Impulse (..), Strategy (..))
 import Dodge.Base
 import Dodge.Path
 import Dodge.SoundLogic
@@ -64,7 +62,7 @@ addImpulse newActions = over (crState . goals) (\(as:ass) -> (newActions++as):as
 
 
 factionIs :: Faction -> Creature -> Bool
-factionIs f c = (_faction $ _crState $ c) == f
+factionIs f c = (_crFaction $ c) == f
 
 lineOrth :: Point2 -> IM.IntMap Creature -> Point2 -> Point2
 lineOrth ypos crs cpos = p
@@ -228,7 +226,7 @@ spawnerAI spawn w (f,g) cr =
         addImpulse newActions 
             = Just . over (crState . goals) (\(as:ass) -> (newActions++as):ass)
 
-        needChild = length (filter (\cr' -> (cr' ^? crState . faction) == Just (SpawnedBy cid)) 
+        needChild = length (filter (\cr' -> (cr' ^? crFaction) == Just (SpawnedBy cid)) 
                                    $ IM.elems $ _creatures w) 
                              < 15
         spawnChild = placeCrFaction spawn (SpawnedBy cid) (cpos +.+ rotateV dir (1,0)) cpos (_crDir cr)
@@ -248,117 +246,11 @@ spawnerAI spawn w (f,g) cr =
 placeCrFaction :: Creature -> Faction -> Point2 -> Point2 -> Float -> World -> World
 placeCrFaction cr fact p op rot w = over creatures addCr w
     where addCr crs = IM.insert (Dodge.Base.newKey crs) 
-                                ( set (crState . faction) fact  
+                                ( set crFaction fact  
                                   $ cr {_crPos = p,_crOldPos = op,_crDir = rot,_crID = Dodge.Base.newKey crs}
                                 ) 
                                 crs
 
--- be aware that the crit can be removed -- don't just refer to its id in the
--- world->world part
-miniAI :: World -> (World -> World,StdGen) -> Creature -> ((World -> World,StdGen), Maybe Creature)
-miniAI w (f,g) cr = 
-    let cpos = _crPos cr
-        cid  = _crID cr
-        ypos = _crPos $ you w
-        wp   = _crInv cr IM.! _crInvSel cr
-        (aimtime,g1) = randomR (80,120) g
-        noAmmo = 0 == _wpLoadedAmmo wp
-        turnCloseSlow p | errorAngleVV 22 (p -.- cpos) 
-                                          (unitVectorAtAngle (_crDir cr)) < 0.4
-                                    =  crTurnTowardSpeed 0.01 p
-                        | otherwise =  crTurnTowardSpeed 0.05 p
-        replaceGoal newImpulses = Just . over (crState . goals) (\gs -> newImpulses ++ tail gs)
-        addGoal newImpulses     = Just . over (crState . goals) (\gs -> newImpulses ++ gs)
-        replaceImpulse newActions 
-            = Just . over (crState . goals) (\((_:as):ass) -> (newActions ++ as):ass)
-        addImpulse newActions 
-            = Just . over (crState . goals) (\(as:ass) -> (newActions++as):ass)
---        autoFireTweak p | _wpIsAuto wp = Just
---                        | otherwise    = replaceGoal [[AimAt p (_itUseRate wp * 2)]]
-    in  --if _crHP cr <= 0 then killCr w f cr else
-    case head $ _goals $ _crState cr of
-        []             | canSeeFire cpos ypos w -> ( ( f , g1 ) 
-                                                   , replaceGoal [[AimAt ypos aimtime]] cr
-                                                   )
-                       | otherwise              -> ( ( f , g )
-                                                   , replaceGoal [] cr
-                                                   )
-        (WaitFor x:gls)| canSeeFire cpos ypos w -> ( ( f , g1 ) 
-                                                   , replaceGoal [[AimAt ypos aimtime]] cr
-                                                   )
-                       | x == 0    -> ( (f ,g ),  replaceImpulse [] cr )
-                       | otherwise -> ( (f ,g ),  replaceImpulse [WaitFor (x-1)] cr )
-        (MoveToFor p x:gls) 
-                       | canSeeFire cpos ypos w -> ( (f , g1) 
-                                                   , replaceGoal [[AimAt ypos aimtime]] cr
-                                                   )
-                       | x == 0    -> ( (f , g)
-                                      , replaceImpulse [] cr
-                                      )
-                       | dist p cpos < 10 -> ( (f , g) , replaceImpulse [] cr)
-                       | angleVV (unitVectorAtAngle (_crDir cr)) (p -.- cpos) > pi/4
-                                   -> ( (f , g)
-                                      , replaceImpulse [MoveToFor p (x-1)] $ crTurnTowardSpeed 0.05 p cr  )
-                       | otherwise -> ( (f , g)
-                                      , replaceImpulse [MoveToFor p (x-1)] $ crMvForward 2 
-                                                                          $ crTurnTowardSpeed 0.05 p cr )
-        (PathTo p:_)   | dist p cpos < 10 -> ( (f , g) , replaceImpulse [] cr )
-                       | hasLOS cpos p w -> ( (f , g) , addImpulse [MoveToFor p 100] cr )
-                       | otherwise -> case pointTowardsImpulse cpos p w of
-                                        Just q -> ( (f , g) , addImpulse [MoveToFor q 100] cr )
-                                        _      -> ( (f , g) , replaceImpulse [] cr            )
-        (FireAt p:gls) | noAmmo -> ( (tryUseItem cid . f , g )
-                                   , replaceGoal [[Reload
-                                                 ,PathTo p
-                                                 ,WaitFor 50
-                                                 --,Search 1 ,WaitFor 100
-                                                 ]] 
-                                                 cr
-                                    )
-                       | canSeeFireVisionAll cid (_yourID w) w 
-                            -> ( (tryUseItem cid . f , g)
-                               , replaceGoal [[FireAt ypos]] $ turnCloseSlow p cr
-                               )
-                       | pathToPointFireable cid p w 
-                            -> ( (tryUseItem cid . f , g)
-                               , Just $ turnCloseSlow p cr
-                               )
-                       | otherwise -> ( (f , g)
-                                      , replaceGoal [[PathTo p,WaitFor 50 ]] cr
-                                      )
-        (Reload:gls)   | _wpReloadState wp == 0 -> ( (f , g) , replaceImpulse [] cr )
-                       | canSeeFireVisionAny cid (_yourID w) w 
-                            -> ( (f , g)
-                               , Just $ turnCloseSlow ypos cr
-                               )  -- no longer chase if see you when reloading
-                                                    --  $ replaceImpulse [] w
-                       | otherwise -> ( (f , g) , Just cr)
-        (Search i:gls) | i == 0 -> ( (f , g) , replaceImpulse [] cr)
-                       | otherwise 
-                            -> ( ( f , g1)
-                               , replaceImpulse [ PathTo (randomPointXStepsFrom 3 cpos w)
-                                               , Search (i-1)
-                                               ] cr
-                                )
-        (Guard p p':_) | dist ypos cpos < 900 && canSeeFireVisionAny cid (_yourID w) w
-                            -> ( ( f , g1)
-                               , addGoal [[AimAt ypos (0)]] cr
-                               )
-                       | dist cpos p > 10
-                            -> ( (f,g) , addGoal [[PathTo p]] cr)
-                       | errorAngleVV 21 (unitVectorAtAngle (_crDir cr)) (p' -.- p) > pi/8
-                            -> ( (f,g)   
-                               ,Just $ crTurnTowardSpeed 0.05 p' cr)
-                       | otherwise -> ( (f,g) ,Just cr)
-        (InitGuard :_) -> ( (f,g)
-                          ,replaceGoal [[Guard cpos (cpos +.+ 50 *.* unitVectorAtAngle (_crDir cr))]] cr
-                          )
-        (AimAt p i:_)  | i == 0 -> ( (f,g) , replaceImpulse [FireAt p] cr )
-                       | canSeeFireVisionAll cid (_yourID w) w
-                            -> ( (f,g) , replaceImpulse [AimAt ypos (i-1)] $ turnCloseSlow p cr)
-                       | otherwise
-                            -> ( (f,g) , replaceImpulse [AimAt p (i-1)] $ turnCloseSlow p cr)
-
 strafeOrChargeAI :: Float -> Float -> World -> (World -> World,StdGen) -> Creature -> ((World -> World,StdGen), Maybe Creature)
 strafeOrChargeAI inRange outRange w (f,g) cr = 
     let cpos = _crPos cr
@@ -1316,106 +1208,6 @@ suppressShooterAI w (f,g) cr =
                        | otherwise
                             -> ( (f,g) , replaceImpulse [AimAt p (i-1)] $ turnCloseSlow p cr)
 
-basicShooterAI :: World -> (World -> World,StdGen) -> Creature -> ((World -> World,StdGen), Maybe Creature)
-basicShooterAI w (f,g) cr = 
-    let cpos = _crPos cr
-        cid  = _crID cr
-        ypos = _crPos $ you w
-        wp   = _crInv cr IM.! _crInvSel cr
-        (aimtime,g1) = randomR (60,80) g
-        noAmmo = 0 == _wpLoadedAmmo wp
-        turnCloseSlow p | errorAngleVV 22 (p -.- cpos) 
-                                          (unitVectorAtAngle (_crDir cr)) < 0.4
-                                    =  crTurnTowardSpeed 0.01 p
-                        | otherwise =  crTurnTowardSpeed 0.05 p
-        replaceGoal newImpulses = Just . over (crState . goals) (\gs -> newImpulses ++ tail gs)
-        addGoal newImpulses     = Just . over (crState . goals) (\gs -> newImpulses ++ gs)
-        replaceImpulse newActions 
-            = Just . over (crState . goals) (\((_:as):ass) -> (newActions ++ as):ass)
-        addImpulse newActions 
-            = Just . over (crState . goals) (\(as:ass) -> (newActions++as):ass)
-    in case head $ _goals $ _crState cr of
-        []             | canSeeFire cpos ypos w -> ( ( f , g1 ) 
-                                                   , replaceGoal [[AimAt ypos aimtime]] cr
-                                                   )
-                       | otherwise              -> ( ( f , g )
-                                                   , replaceGoal [] cr
-                                                   )
-        (WaitFor x:gls)| canSeeFire cpos ypos w -> ( ( f , g1 ) 
-                                                   , replaceGoal [[AimAt ypos aimtime]] cr
-                                                   )
-                       | x == 0    -> ( (f ,g ),  replaceImpulse [] cr )
-                       | otherwise -> ( (f ,g ),  replaceImpulse [WaitFor (x-1)] cr )
-        (MoveToFor p x:gls) 
-                       | canSeeFire cpos ypos w -> ( (f , g1) 
-                                                   , replaceGoal [[AimAt ypos aimtime]] cr
-                                                   )
-                       | x == 0    -> ( (f , g)
-                                      , replaceImpulse [] cr
-                                      )
-                       | dist p cpos < 10 -> ( (f , g) , replaceImpulse [] cr)
-                       | angleVV (unitVectorAtAngle (_crDir cr)) (p -.- cpos) > pi/4
-                                   -> ( (f , g)
-                                      , replaceImpulse [MoveToFor p (x-1)] $ crTurnTowardSpeed 0.05 p cr  )
-                       | otherwise -> ( (f , g)
-                                      , replaceImpulse [MoveToFor p (x-1)] $ crMvForward 2 
-                                                                          $ crTurnTowardSpeed 0.05 p cr )
-        (PathTo p:_)   | dist p cpos < 10 -> ( (f , g) , replaceImpulse [] cr )
-                       | hasLOS cpos p w -> ( (f , g) , addImpulse [MoveToFor p 100] cr )
-                       | otherwise -> case pointTowardsImpulse cpos p w of
-                                        Just q -> ( (f , g) , addImpulse [MoveToFor q 100] cr )
-                                        _      -> ( (f , g) , replaceImpulse [] cr            )
-        (FireAt p:gls) | noAmmo -> ( (tryUseItem cid . f , g )
-                                   , replaceGoal [[Reload
-                                                 ,PathTo p
-                                                 ,WaitFor 50
-                                                 --,Search 1 ,WaitFor 100
-                                                 ]] 
-                                                 cr
-                                    )
-                       | canSeeFireVisionAll cid (_yourID w) w 
-                            -> ( (tryUseItem cid . f , g)
-                               , replaceGoal [[FireAt ypos]] $ turnCloseSlow p cr
-                               )
-                       | pathToPointFireable cid p w 
-                            -> ( (tryUseItem cid . f , g)
-                               , Just $ turnCloseSlow p cr
-                               )
-                       | otherwise -> ( (f , g)
-                                      , replaceGoal [[PathTo p,WaitFor 50 ]] cr
-                                      )
-        (Reload:gls)   | _wpReloadState wp == 0 -> ( (f , g) , replaceImpulse [] cr )
-                       | canSeeFireVisionAny cid (_yourID w) w 
-                            -> ( (f , g)
-                               , Just $ turnCloseSlow ypos cr
-                               )  -- no longer chase if see you when reloading
-                                                    -- -$ replaceImpulse [] w
-                       | otherwise -> ( (f , g) , Just cr)
-        (Search i:gls) | i == 0 -> ( (f , g) , replaceImpulse [] cr)
-                       | otherwise 
-                            -> ( ( f , g1)
-                               , replaceImpulse [ PathTo (randomPointXStepsFrom 3 cpos w)
-                                               , Search (i-1)
-                                               ] cr
-                                )
-        (Guard p p':_) | dist ypos cpos < 900 && canSeeFireVisionAny cid (_yourID w) w
-                            -> ( ( f , g1)
-                               , addGoal [[AimAt ypos (2*aimtime)]] cr
-                               )
-                       | dist cpos p > 10
-                            -> ( (f,g) , addGoal [[PathTo p]] cr)
-                       | errorAngleVV 21 (unitVectorAtAngle (_crDir cr)) (p' -.- p) > pi/8
-                            -> ( (f,g)   
-                               ,Just $ crTurnTowardSpeed 0.05 p' cr)
-                       | otherwise -> ( (f,g) ,Just cr)
-        (InitGuard :_) -> ( (f,g)
-                          ,replaceGoal [[Guard cpos (cpos +.+ 50 *.* unitVectorAtAngle (_crDir cr))]] cr
-                          )
-        (AimAt p i:_)  | i == 0 -> ( (f,g) , replaceImpulse [FireAt p] cr )
-                       | canSeeFireVisionAll cid (_yourID w) w
-                            -> ( (f,g) , replaceImpulse [AimAt ypos (i-1)] $ turnCloseSlow p cr)
-                       | otherwise
-                            -> ( (f,g) , replaceImpulse [AimAt p (i-1)] $ turnCloseSlow p cr)
 
 sniperAI :: World -> (World -> World,StdGen) -> Creature -> ((World -> World,StdGen), Maybe Creature)
 sniperAI w (f,g) cr = 

src/Dodge/Base.hs

@@ -58,6 +58,11 @@ aCrPos i w = _crPos $ _creatures w IM.! i
 yourItem :: World -> Item
 yourItem w = _crInv (you w) IM.! _crInvSel (you w)
 
+crItem :: World -> Int -> Item
+crItem w cid = _crInv cr IM.! _crInvSel cr
+  where
+    cr = _creatures w IM.! cid
+
 yourItemRef w = (creatures . ix (_yourID w) . crInv . ix (_crInvSel (you w)))
 
 wallNormal :: Wall -> Point2
@@ -495,3 +500,9 @@ mvPointToward
 mvPointToward !ep !p 
     | dist p ep < 1 = ep
     | otherwise     = p +.+ normalizeV (ep -.- p)
+
+isAnimate :: Creature -> Bool
+{-# INLINE isAnimate #-}
+isAnimate cr = case _crActionPlan cr of
+    Inanimate -> False
+    _   -> True

src/Dodge/Creature.hs

@@ -10,6 +10,8 @@ import Dodge.Creature.ImpulseRat
 import Dodge.Creature.ActionRat
 import Dodge.Creature.Rationality.Data
 import Dodge.Creature.AlertLevel
+import Dodge.Creature.SetTarget
+import Dodge.Creature.Test
 import Dodge.Data
 import Dodge.AIs
 import Dodge.Default
@@ -64,10 +66,10 @@ smallChaseCrit = defaultCreature
     , _crPict = basicCrPict green
     , _crState = defaultState 
         {_goals = [[Wait]]
-        ,_faction = ChaseCritters
         }
     , _crInv = IM.empty -- IM.fromList [(0,frontArmour)]
     , _crCorpse = onLayer CorpseLayer $ color (greyN 0.5) $ circleSolid 4
+    , _crFaction = ColorFaction green
     }
 chaseCrit :: Creature
 chaseCrit = defaultCreature
@@ -76,10 +78,10 @@ chaseCrit = defaultCreature
     , _crPict = basicCrPict green
     , _crState = defaultState 
         {_goals = [[Wait]]
-        ,_faction = ChaseCritters
         }
     , _crInv = IM.empty 
     , _crMeleeCooldown = Just 0
+    , _crFaction = ColorFaction green
     }
 armourChaseCrit :: Creature
 armourChaseCrit = defaultCreature
@@ -92,12 +94,12 @@ armourChaseCrit = defaultCreature
         ,(1,medkit 200)
         ]
     }
-miniGunCrit' :: Creature
+miniGunCrit :: Creature
-miniGunCrit' = defaultCreature
+miniGunCrit = defaultCreature
     { _crPict = basicCrPict red
     , _crUpdate = stateUpdate $ impulsiveAI $ composeInternalAIs
-        [ actionUpdateAI performActions
+        [ performActions
-        , shootAtTarget targetYouCognizant 
+        , shootTargetWithStrat targetYouCognizant suppress
         , basicPerceptionUpdate [0]
         ]
     , _crInv = IM.fromList [(0,miniGun)]
@@ -105,20 +107,6 @@ miniGunCrit' = defaultCreature
     , _crRad = 10
     , _crState = defaultState
     , _crHP = 500
-    , _crRationality = ActionRat 
-        { _crImpulse = []
-        , _crAction  = [AimAtCloseSlow 0 (0,0) 0.2 0.01 (pi/4) ]
-        }
-    }
-miniGunCrit :: Creature
-miniGunCrit = defaultCreature
-    { _crPict = basicCrPict red
-    , _crUpdate = stateUpdate  miniAI
-    , _crInv = IM.fromList [(0,miniGun)]
-    , _crInvSel = 0
-    , _crRad = 10
-    , _crState = defaultState {_goals = [[InitGuard]]}
-    , _crHP = 500
     }
 longCrit :: Creature
 longCrit = defaultCreature
@@ -133,12 +121,31 @@ longCrit = defaultCreature
 multGunCrit :: Creature
 multGunCrit = defaultCreature
     { _crPict = basicCrPict red
-    , _crUpdate = stateUpdate (twitchMissAI 300 350)
+--    , _crUpdate = stateUpdate (twitchMissAI 300 350)
     , _crInv = IM.fromList [(0,multGun),(1,medkit 100)]
     , _crInvSel = 0
     , _crRad = 10
     , _crState = defaultState {_goals = [[InitGuard]]}
     , _crHP = 300
+    , _crUpdate = stateUpdate $ impulsiveAI $ composeInternalAIs
+        [ performActions
+        , watchUpdateStrat
+            [ (crHasTargetLOS, shootFirstMiss 0)
+            , (crAwayFromPost, goToPostStrat)
+            ]
+        , basicPerceptionUpdate [0]
+        , doStrategyActions
+        , reloadOverride
+        , targetYouWhenCognizant
+        , overrideInternal (onBoth (&&) crHasTarget (crStratConMatches (GetTo (0,0))))
+            $ \ _ -> crActionPlan . crStrategy .~ WatchAndWait
+        ]
+    , _crActionPlan = ActionPlan
+        { _crImpulse    = []
+        , _crAction     = []
+        , _crStrategy   = WatchAndWait
+        , _crGoal       = []
+        }
     }
 launcherCrit :: Creature
 launcherCrit = defaultCreature
@@ -173,7 +180,25 @@ pistolCrit = defaultCreature
 autoCrit :: Creature
 autoCrit = defaultCreature
     { _crPict = basicCrPict red
-    , _crUpdate = stateUpdate  basicShooterAI
+    , _crUpdate = stateUpdate $ impulsiveAI $ composeInternalAIs
+        [ performActions
+        , watchUpdateStrat
+            [ (crHasTargetLOS, shootAdvanceStrat 0)
+            , (crAwayFromPost, goToPostStrat)
+            ]
+        , basicPerceptionUpdate [0]
+        , doStrategyActions
+        , reloadOverride
+        , targetYouWhenCognizant
+        , overrideInternal (onBoth (&&) crHasTarget (crStratConMatches (GetTo (0,0))))
+            $ \ _ -> crActionPlan . crStrategy .~ WatchAndWait
+        ]
+    , _crActionPlan = ActionPlan
+        { _crImpulse    = []
+        , _crAction     = []
+        , _crStrategy   = StrategyActions [StartSentinelPost] WatchAndWait
+        , _crGoal       = []
+        }
     , _crInv = IM.fromList [(0,autoGun),(1,medkit 100)]
     , _crInvSel = 0
     , _crRad = 10
@@ -246,6 +271,7 @@ startCr = defaultCreature
     , _crMaxHP = 1500
     , _crInv = startInventory 
     , _crCorpse = onLayer CorpseLayer $ color (greyN 0.5) $ pictures [color (greyN 0.8) $ circleSolid 10, circLine 10]
+    , _crFaction = PlayerFaction
     }
 {- |
 Items you start with.
@@ -253,6 +279,7 @@ Items you start with.
 startInventory = IM.fromList (zip [0..20] 
     (
     [bezierGun
+    ,multGun
     ,hvAutoGun
     ,remoteLauncher
     ,grenade

src/Dodge/Creature/Action.hs

@@ -355,6 +355,14 @@ advanceStepCounter speed cr = over (crStance . carriage) f cr
 creatureTurn :: Float -> Creature -> Creature
 creatureTurn a = crDir +~ a
 
+creatureTurnTo :: Point2 -> Creature -> Creature
+creatureTurnTo p cr 
+    | vToTarg == (0,0)  = cr -- this should deal with the angleVV error
+    | otherwise         = cr & crDir .~ dirToTarget
+  where
+    vToTarg = p -.- _crPos cr
+    dirToTarget = argV vToTarg
+
 creatureTurnToward :: Point2 -> Float -> Creature -> Creature
 creatureTurnToward p turnSpeed cr 
     | vToTarg == (0,0) = cr -- this should deal with the angleVV error

src/Dodge/Creature/Action/UseItem.hs

@@ -13,7 +13,8 @@ useItem :: Int -> World -> World
 useItem n w = equippedItemEffect n w
 
 crUseItem :: Creature -> World -> World
-crUseItem cr = itemEffect (_crID cr) (_crInv cr IM.! _crInvSel cr)
+--crUseItem cr = itemEffect (_crID cr) (_crInv cr IM.! _crInvSel cr)
+crUseItem cr = tryUseItem (_crID cr)
 
 tryUseItem 
     :: Int      -- ^ Creature id

src/Dodge/Creature/ActionRat.hs

@@ -1,25 +1,212 @@
 module Dodge.Creature.ActionRat
+    ( shootTargetWithStrat
+    , suppressShootTarget
+    , suppress
+    , shootAdvance
+    , shootFirstMiss
+    , doStrategyActions
+    , reloadOverride
+    , shootAdvanceStrat
+    , watchUpdateStrat
+    , goToPostStrat
+    , overrideInternal
+    )
     where
 import Dodge.Data
+import Dodge.Base
 import Dodge.Base.Collide
 import Dodge.Creature.ChooseTarget
 import Dodge.Creature.Rationality.Data
+import Dodge.Creature.Stance.Data
+import Dodge.Creature.Test
 import Geometry
 
 import Data.List
+import qualified Data.IntMap.Strict as IM
 import Control.Lens
 
+shootTargetWithStrat
+    :: (Creature -> World -> Maybe Creature)    -- ^ Function for determining target
+    -> (World -> Creature -> Creature -> [Action] -> [Action])
+            -- ^ Function for determining shooting strategy given target
+    -> World 
+    -> Creature 
+    -> Creature 
+shootTargetWithStrat targFunc strat w cr = case targFunc cr w of
+    Nothing -> cr
+    Just crTarg -> cr & crActionPlan . crAction %~ strat w cr crTarg
+
 {- | Action update for a simple shooting creature -}
-shootAtTarget
+suppressShootTarget
     :: (Creature -> World -> Maybe Creature)    -- ^ Function for determining target
     -> World 
     -> Creature 
     -> Creature 
-shootAtTarget targFunc w cr = case targFunc cr w of
+suppressShootTarget targFunc w cr = case targFunc cr w of
     Nothing -> cr
-    Just crTarg -> cr & crRationality . crAction %~ shootAtTarg w cr crTarg
+    Just crTarg -> cr & crActionPlan . crAction %~ suppress w cr crTarg
 
-shootAtTarg :: World -> Creature -> Creature -> [Action] -> [Action]
+suppress :: World -> Creature -> Creature -> [Action] -> [Action]
-shootAtTarg w cr tcr as
+suppress w cr tcr as
-    | canSee (_crID cr) (_crID tcr) w = nub (ShootTillEmpty : as)
+    | canSee (_crID cr) (_crID tcr) w && cr ^. crStance . posture /= Aiming 
-    | otherwise     = as
+        && cr ^? crInv . ix (_crInvSel cr) . wpReloadState == Just 0 = 
+        [ DrawWeapon
+        , WaitThen 50 ShootTillEmpty
+        , AimAtCloseSlow 
+            { _targetID = _crID tcr
+            , _targetSeenAt = _crPos cr
+            , _aimSpeed = 0.2
+            , _slowAimSpeed = 0.01
+            , _slowAimAngle = pi/4
+            }
+        ]
+    | otherwise = as
+
+shootFirstMiss :: Int -> World -> Creature -> Strategy
+shootFirstMiss tcid w cr = StrategyActions acs (ShootAt tcid)
+  where
+    acs = 
+        [ DoActionIfElse NoAction crIsAiming (DoActionThen DrawWeapon (WaitThen 50 NoAction))
+          `DoActionThen`
+          LeadTarget (10,50)
+          `DoActionThen`
+          advanceShoot
+          `DoActionThen`
+          LeadTarget (50,0)
+          `DoActionThen`
+          (advanceShoot `DoActionWhileThen` lostest
+          $ DoReplicateThen advanceShoot 75
+          $ DoImpulses [ChangeStrategy WatchAndWait]
+          )
+        ]
+    lostest (w,cr') = canSee (_crID cr') tcid w 
+    advanceShoot = ImpulsesList [[UseItem, MoveForward 3]]
+    
+
+shootAdvanceStrat :: Int -> World -> Creature -> Strategy
+shootAdvanceStrat tcid _ _ = StrategyActions acs (ShootAt tcid)
+  where
+    acs = 
+        [ DoActionIfElse NoAction crIsAiming (DoActionThen DrawWeapon (WaitThen 50 NoAction))
+          `DoActionThen`
+          (DoActionWhileThen advanceShoot lostest
+          . DoReplicateThen advanceShoot 75
+          $ DoImpulses [ChangeStrategy WatchAndWait]
+          )
+        , AimAtCloseSlow 
+            { _targetID = tcid
+            , _targetSeenAt = (0,0) -- hack
+            , _aimSpeed = 0.2
+            , _slowAimSpeed = 0.01
+            , _slowAimAngle = pi/8
+            }
+        ]
+    lostest (w,cr') = canSee (_crID cr') tcid w 
+    advanceShoot = ImpulsesList [[UseItem, MoveForward 3]]
+
+goToPostStrat :: World -> Creature -> Strategy
+goToPostStrat w cr = case find sentinelGoal $ _crGoal $ _crActionPlan cr of
+    Just (SentinelAt p _) -> StrategyActions 
+        [DoActionThen (WaitThen 150 holsterIfAiming)
+            $ DoActionThen (PathTo p) 
+            NoAction
+       --     $ DoImpulses [ChangeStrategy WatchAndWait]
+        ] $ GetTo p 
+    _ -> WatchAndWait
+  where
+    sentinelGoal (SentinelAt p dir) = True
+    sentinelGoal _ = False
+    holsterIfAiming 
+        | crIsAiming (w,cr) = HolsterWeapon
+        | otherwise     = NoAction
+
+overrideInternal 
+    :: ((World , Creature) -> Bool)
+    -> (World -> Creature -> Creature)
+    -> World
+    -> Creature
+    -> Creature
+overrideInternal test update w cr
+    | test (w,cr) = update w cr
+    | otherwise = cr
+
+shootAdvance :: World -> Creature -> Creature -> [Action] -> [Action]
+shootAdvance w cr tcr as
+    | lostest (w,cr) && cr ^. crStance . posture /= Aiming 
+        && cr ^? crInv . ix (_crInvSel cr) . wpReloadState == Just 0 = 
+        [ DrawWeapon
+        , DoImpulses [ChangeStrategy $ ShootAt $ _crID tcr]
+        , WaitThen 50 
+            . DoActionWhileThen advanceShoot lostest
+            . DoReplicateThen advanceShoot 50
+            $ DoImpulses [ChangeStrategy WatchAndWait]
+        , AimAtCloseSlow 
+            { _targetID = _crID tcr
+            , _targetSeenAt = _crPos cr
+            , _aimSpeed = 0.2
+            , _slowAimSpeed = 0.01
+            , _slowAimAngle = pi/8
+            }
+        ]
+    | cr ^. crStance . posture == Aiming && cr ^? crInv . ix (_crInvSel cr) . wpReloadState /= Just 0 
+        = [ HolsterWeapon ]
+    | otherwise = as
+  where
+    lostest (w,cr') = canSee (_crID cr) (_crID tcr) w 
+    advanceShoot = ImpulsesList [[UseItem, MoveForward 3]]
+
+applyNewStrategies
+    :: World
+    -> Creature
+    -> Creature
+applyNewStrategies w cr = case cr ^? crActionPlan . crStrategy of
+    Just (StrategyActions acs strat) -> cr & crActionPlan . crAction .~ acs
+        & crActionPlan . crStrategy .~ strat
+    otherwise -> cr
+
+doStrategyActions
+    :: World
+    -> Creature
+    -> Creature
+doStrategyActions w cr = case cr ^? crActionPlan . crStrategy of
+    Just (StrategyActions acs strat) -> cr & crActionPlan . crAction .~ acs
+        & crActionPlan . crStrategy .~ strat
+    otherwise -> cr
+
+updateShoot
+    :: World
+    -> Creature
+    -> Creature
+updateShoot w cr = case _crStrategy $ _crActionPlan cr of
+    WatchAndWait -> undefined
+
+reloadOverride
+    :: World
+    -> Creature
+    -> Creature
+reloadOverride _ cr
+    | cr ^? crInv . ix (_crInvSel cr) . wpLoadedAmmo == Just 0 
+            && cr ^. crStance . posture == Aiming
+        = cr & crActionPlan . crStrategy .~ StrategyActions reloadActions Reload
+    | otherwise = cr
+  where
+    reloadActions = 
+        [ HolsterWeapon
+        , WaitThen 1 $ DoActionWhileThen NoAction crIsReloading (DoImpulses [ChangeStrategy WatchAndWait])
+        ]
+
+watchUpdateStrat 
+    :: [ ((World, Creature) -> Bool, World -> Creature -> Strategy) ]
+    -> World
+    -> Creature
+    -> Creature
+watchUpdateStrat fs w cr = case cr ^? crActionPlan . crStrategy of
+    Just WatchAndWait -> cr 
+        & crActionPlan . crStrategy .~ listGuard (fs, (\_ _ -> WatchAndWait)) (w, cr) w cr
+    _ -> cr
+
+listGuard :: ([(a -> Bool, b)] , b) -> a -> b
+listGuard ( (test,y):ps, z ) x
+    | test x = y
+    | otherwise = listGuard (ps, z) x
+listGuard (_,z) _ = z

src/Dodge/Creature/ImpulseRat.hs

@@ -14,7 +14,7 @@ chaseTarget
     -> Creature 
 chaseTarget targFunc w cr = case targFunc cr w of
     Nothing -> cr
-    Just crTarg -> cr & crRationality . crImpulse .~ chaseTarg cr crTarg
+    Just crTarg -> cr & crActionPlan . crImpulse .~ chaseTarg cr crTarg
 
 chaseTarg :: Creature -> Creature -> [Impulse]
 chaseTarg cr crT
@@ -40,7 +40,7 @@ impulseShootAtTarget
     -> Creature 
 impulseShootAtTarget targFunc w cr = case targFunc cr w of
     Nothing -> cr
-    Just crTarg -> cr & crRationality . crImpulse .~ impulseShootAtTarg cr crTarg
+    Just crTarg -> cr & crActionPlan . crImpulse .~ impulseShootAtTarg cr crTarg
 
 impulseShootAtTarg :: Creature -> Creature -> [Impulse]
 impulseShootAtTarg cr crT

src/Dodge/Creature/Inanimate.hs

@@ -20,7 +20,7 @@ import Picture
 import qualified Data.IntMap.Strict as IM
 import Control.Lens
 
-defaultInanimate = defaultCreature & crState . crIsAnimate .~ False
+defaultInanimate = defaultCreature & crActionPlan .~ Inanimate
 
 lamp :: Creature
 lamp = defaultInanimate
@@ -60,7 +60,6 @@ barrel = defaultInanimate
         ]
     , _crState = defaultState 
         {_goals = [[Wait]]
-        ,_faction = ChaseCritters
         ,_crSpState = Barrel []
         }
     , _crInv = IM.empty -- IM.fromList [(0,frontArmour)]
@@ -76,7 +75,6 @@ explosiveBarrel = defaultInanimate
         ]
     , _crState = defaultState 
         {_goals = [[Wait]]
-        ,_faction = ChaseCritters
         ,_crSpState = Barrel []
         }
     , _crInv = IM.empty -- IM.fromList [(0,frontArmour)]

src/Dodge/Creature/Picture.hs

@@ -6,6 +6,7 @@ module Dodge.Creature.Picture
     , circLine
     ) where
 import Dodge.Data
+import Dodge.Creature.Stance.Data
 import Dodge.Creature.State.Data
 import Dodge.Creature.AlertLevel.Data
 import Dodge.Picture.Layer
@@ -21,7 +22,7 @@ basicCrPict
     -> Picture
 basicCrPict col cr = pictures 
     [ onLayer CrLayer . piercingMod $ bluntScale naked 
-    , drawAwakeLevel cr
+--    , drawAwakeLevel cr
     , drawEquipment cr
     ]
   where 
@@ -66,7 +67,7 @@ drawEquipment
 drawEquipment cr = pictures $ map f $ IM.toList (_crInv cr)
   where 
     f (i,it) = case it ^? itEquipPict of
-        Just g -> g cr i
+        Just g | (cr ^? crStance . posture) == Just Aiming -> g cr i
         _      -> blank
 
 circLine x = line [(0,0),(x,0)]

src/Dodge/Creature/Rationality.hs

@@ -6,6 +6,7 @@ import Dodge.Creature.Rationality.Data
 import Dodge.Creature.Action
 import Dodge.Creature.Action.UseItem
 import Dodge.Creature.State.Data
+import Dodge.Creature.Stance.Data
 import Dodge.SoundLogic
 import Geometry
 
@@ -14,6 +15,8 @@ import qualified Data.IntMap.Strict as IM
 import System.Random
 import Control.Lens
 
+-- Alternatives would probably be a very good fit for actions...
+
 composeInternalAIs 
     :: [World -> Creature -> Creature]
     -> World
@@ -39,7 +42,7 @@ followImpulses w (f,g) cr
     $ foldr 
         (\imp (f' , cr') -> let (f'', cr'') = followImpulse imp w cr' in (f'' . f', cr''))
         (f, cr) 
-        (_crImpulse $ _crRationality cr)
+        (_crImpulse $ _crActionPlan cr)
   where
     g' = snd $ next g
 
@@ -53,14 +56,20 @@ followImpulse imp w cr = case imp of
     MoveForward x  -> (id, crMvForward x cr)
     Turn a  -> (id, creatureTurn a cr)
     TurnToward p a -> (id, creatureTurnToward p a cr)
---    UseItem -> (crUseItem cr, cr)
+    TurnTo p -> (id, creatureTurnTo p cr)
+    ChangePosture post -> (id, cr & crStance . posture .~ post)
+    UseItem -> (crUseItem cr, cr)
     SwitchToItem i -> (id, cr & crInvSel .~ i)
     Melee crID -> 
         (hitCr crID
         , crMvBy (10 *.* normalizeV (posFromID crID -.- cpos)) $ cr & crMeleeCooldown ?~ 20) -- randomise cooldown?
     RandomTurn a -> (id, creatureTurn (rr a) cr)
-    _ -> (id , cr)
+    MakeSound sid -> ( soundOnceOrigin sid (CrSound (_crID cr)) (_crPos cr) , cr )
     DropItem -> undefined
+    ChangeStrategy strat -> (id, cr & crActionPlan . crStrategy .~ strat)
+    AddGoal gl -> (id, cr & crActionPlan . crGoal %~ (gl :) )
+    ArbitraryCreatureImpulse f -> (id, f w cr)
+    _ -> (id , cr)
   where
     cpos = _crPos cr
     posFromID cid = _crPos $ _creatures w IM.! cid
@@ -78,10 +87,10 @@ actionUpdateAI actF w c = performActions w $ actF w c
 
 performActions :: World -> Creature -> Creature
 performActions w cr = cr
-    & crRationality . crImpulse .~ concat iss
+    & crActionPlan . crImpulse .~ concat iss
-    & crRationality . crAction .~ catMaybes mayas
+    & crActionPlan . crAction .~ catMaybes mayas
   where
-    (iss, mayas) = unzip $ map (performAction cr w) $ cr ^. crRationality . crAction
+    (iss, mayas) = unzip $ map (performAction cr w) $ cr ^. crActionPlan . crAction
 
 {- | Performing an action means that a creature has some impulses for a frame, and
  updates or deletes the action itself. -}
@@ -91,9 +100,9 @@ performAction
     -> Action
     -> ( [Impulse] , Maybe Action )
 performAction cr w ac = case ac of
-    ShootTillEmpty -> case cr ^? crInv . ix (_crInvSel cr) . wpLoadedAmmo of
+    ShootTillEmpty -> case cr ^? crInv . ix (_crInvSel cr) . wpReloadState of
-        Just x | x > 0  -> ( [UseItem] , Just ShootTillEmpty )
+        Just x | x == 0  -> ( [UseItem] , Just ShootTillEmpty )
-        _               -> ( []        , Nothing )
+        _                -> ( []        , Just (WaitThen 20 HolsterWeapon) )
     AimAtCloseSlow tcid p speed slowSpeed a
         | canSee (_crID cr) tcid w && safeAngleVV (unitVectorAtAngle cdir) (tpos -.- cpos) < a 
             -> ([TurnToward tpos slowSpeed] , Just $ AimAtCloseSlow tcid tpos speed slowSpeed a)
@@ -104,9 +113,41 @@ performAction cr w ac = case ac of
         | otherwise -> ([TurnToward p speed] , Just $ AimAtCloseSlow tcid p speed slowSpeed a)
       where
         tpos = _crPos (_creatures w IM.! tcid)
+    WaitThen 0 newAc -> ([] , Just newAc)
+    WaitThen t newAc -> ([] , Just (WaitThen (t-1) newAc))
     ImpulsesList (xs:xss) -> (xs, Just $ ImpulsesList xss)
     ImpulsesList _  -> ([], Nothing)
+    DoImpulses imps -> (imps, Nothing)
+    DrawWeapon -> ([ChangePosture Aiming, MakeSound pickUpSound] , Nothing)
+    HolsterWeapon -> ([ChangePosture AtEase, MakeSound putDownSound] , Nothing)
+    DoActionThen ac ac' -> case performAction cr w ac of
+        (imps , Just ac'') -> (imps, Just (DoActionThen ac'' ac'))
+        (imps , Nothing  ) -> (imps, Just ac')
+    DoActionWhile ac f 
+        | f (w,cr) -> (fst $ performAction cr w ac, Just $ DoActionWhile ac f)
+        | otherwise -> ([], Nothing)               
+    DoActionIfElse ac f ac'
+        | f (w,cr)      -> performAction cr w ac
+        | otherwise -> performAction cr w ac'
+    DoActionWhileThen ac f ac'
+        | f (w,cr)       -> (fst $ performAction cr w ac, Just $ DoActionWhileThen ac f ac')
+        | otherwise -> performAction cr w ac'
+    DoReplicateThen ac 0 ac' -> performAction cr w ac'
+    DoReplicateThen ac t ac' -> (fst $ performAction cr w ac, Just $ DoReplicateThen ac (t-1) ac')
+    DoActions [] -> ([], Nothing)
+    DoActions acs -> 
+        let (imps, newAcs) = unzip $ map (performAction cr w) acs
+        in (concat imps, Just . DoActions $ catMaybes newAcs)
+    StartSentinelPost -> ([AddGoal $ SentinelAt (_crPos cr) (_crDir cr)], Nothing)
+    PathTo p
+        | dist cpos p < 5 -> ([], Nothing)
+        | hasLOS cpos p w -> ([TurnToward p (pi/4),MoveForward 3] , Just (PathTo p))
+        | otherwise -> ([], Nothing)
+    LeadTarget p -> case cr ^? crTarget . _Just of
+        Just tcid -> let tcr = _creatures w IM.! tcid
+            in ([TurnTo (_crPos tcr +.+ rotateV (_crDir tcr) p)], Nothing)
+        _  -> ([], Nothing)
+    _ -> ([], Nothing)
   where
     cpos = _crPos cr 
     cdir = _crDir cr
-    

src/Dodge/Creature/Rationality/Data.hs

@@ -6,64 +6,3 @@ import Dodge.Creature.Stance.Data
 import Geometry.Data
 
 import Control.Lens
-data Rationality
-    = NonRat
-    | ImpulseRat
-        {_crImpulse :: [Impulse] }
-    | ActionRat
-        {_crImpulse :: [Impulse]
-        ,_crAction  :: [Action]
-        }
-    | StrategyRat
-        {_crImpulse     :: [Impulse]
-        ,_crAction      :: [Action]
-        ,_crStrategy    :: Strategy
-        }
-data Impulse
-    = Move Point2
-    | MoveForward Float
-    | Turn Float
-    | RandomTurn Float
-    | TurnToward Point2 Float
-    | UseItem
-    | SwitchToItem Int
-    | DropItem
-    | PickupNearby Int
-    | UseWorldObject Int
-    | Bark -- placeholder for various communication types
-    | UseIntrinsicAbility
-    | Melee Int
-    | ChangePosture Posture
-  deriving (Eq,Ord,Show)
-
-data Action
-    = Attack Int
-    | AimAtCloseSlow 
-        {_targetID :: Int 
-        ,_targetSeenAt :: Point2 
-        ,_aimSpeed :: Float 
-        ,_slowAimSpeed :: Float
-        ,_slowAimAngle :: Float
-        }
-    | MeleeAttack Point2 Int
-    | PathTo Point2
-    | FleeFrom Int
-    | HealSelf
-    | DefendSelf
-    | Protect Int
-    | SearchFor Int
-    | Search
-    | PickupItem Int
-    | ShootTillEmpty
-    | ImpulsesList [[Impulse]]
-  deriving (Eq,Ord,Show)
-
-data Strategy
-    = Flank Int
-    | Ambush Int
-    | Lure Int Point2
-    | GuardArea Point2
-    | Patrol [Point2]
-
-makeLenses ''Rationality
-makeLenses ''Impulse

src/Dodge/Creature/SetTarget.hs

@@ -0,0 +1,16 @@
+{- |
+Deals with setting a target for creatures
+-}
+module Dodge.Creature.SetTarget
+    where
+import Dodge.Data
+import Dodge.Creature.AlertLevel.Data
+
+import Control.Lens
+targetYouWhenCognizant
+    :: World
+    -> Creature
+    -> Creature
+targetYouWhenCognizant w cr = case cr ^? crAwarenessLevel . ix 0 of
+    Just (Cognizant _)  -> cr & crTarget .~ Just 0
+    _                   -> cr & crTarget .~ Nothing

src/Dodge/Creature/State.hs

@@ -116,23 +116,24 @@ movementSideEff cr w
     | otherwise = case cr ^? crStance . carriage of
                     Just (Walking x y) -> takeStep x y w
                     _ -> w
-        where hasJetPack = any (\it -> it ^? itIdentity == Just JetPack) $ _crInv cr
+  where 
-              oldPos = _crOldPos cr
+    hasJetPack = any (\it -> it ^? itIdentity == Just JetPack) $ _crInv cr
-              momentum' = 0.97 *.* (_crPos cr -.- _crOldPos cr)
+    oldPos = _crOldPos cr
-              momentum'' | magV momentum' > 3 = 3 *.* normalizeV momentum'
+    momentum' = 0.97 *.* (_crPos cr -.- _crOldPos cr)
-                         | otherwise          = momentum'
+    momentum'' | magV momentum' > 3 = 3 *.* normalizeV momentum'
-              momentum = momentum'' +.+ 0.01 *.* unitVectorAtAngle randAng
+               | otherwise          = momentum'
-              (randDir,g) = randomR (-0.5,0.5) $ _randGen w
+    momentum = momentum'' +.+ 0.01 *.* unitVectorAtAngle randAng
-              (randAng,_) = randomR (0,2*pi) $ _randGen w
+    (randDir,g) = randomR (-0.5,0.5) $ _randGen w
+    (randAng,_) = randomR (0,2*pi) $ _randGen w
 
-              (v1:v2:v3:_) = fst $ runState ((sequence . repeat . randInCirc) 0.1) $ _randGen w
+    (v1:v2:v3:_) = fst $ runState ((sequence . repeat . randInCirc) 0.1) $ _randGen w
-              (r1:r2:r3:_) = map ((*.*) 100) (v2:v3:v1:[])
+    (r1:r2:r3:_) = map ((*.*) 100) (v2:v3:v1:[])
 
-              crHasMoved = dist (_crPos cr) (_crOldPos cr) > 0.5
+    crHasMoved = dist (_crPos cr) (_crOldPos cr) > 0.5
-              takeStep x y | crHasMoved && x < 20 && x + y >= 20 = soundMultiFrom footor 22 3 0
+    takeStep x y | crHasMoved && x < 20 && x + y >= 20 = soundMultiFrom footor 22 3 0
-                           | crHasMoved && x < 80 && x + y >= 80 = soundMultiFrom footor 23 3 0  
+                 | crHasMoved && x < 80 && x + y >= 80 = soundMultiFrom footor 23 3 0  
-                           | otherwise = id
+                 | otherwise = id
-              footor = [FootstepSound 0,FootstepSound 1]
+    footor = [FootstepSound 0,FootstepSound 1]
 
 invSideEff :: Creature -> World -> World
 invSideEff cr w = weaponReloadSounds cr $ IM.foldrWithKey f w (_crInv cr)
@@ -142,29 +143,22 @@ invSideEff cr w = weaponReloadSounds cr $ IM.foldrWithKey f w (_crInv cr)
 
 weaponReloadSounds :: Creature -> World -> World
 weaponReloadSounds cr w = case _crInv cr IM.!? _crInvSel cr of
-                              Just (Weapon {_wpReloadState = 0})
+    Just (Weapon {_wpReloadState = 0}) -> w
-                                 -> w
+    Just (Weapon {_wpReloadState = 1}) -> stopSoundFrom (CrReloadSound cid) w
-                              Just (Weapon {_wpReloadState = 1})
+    Just (Weapon {}) -> soundFrom (CrReloadSound cid) reloadSound (1) 0 w
-                                 -> stopSoundFrom (CrReloadSound cid) w
+    _ -> w
-                              Just (Weapon {})
+  where 
-                                 -> soundFrom (CrReloadSound cid) reloadSound (1) 0 w
+    cid = _crID cr
-                              _
-                                 -> w
-      where cid = _crID cr
 
 updateMovement :: StdGen -> Creature -> (Creature, StdGen)
 updateMovement g cr 
-    | isFrictionless cr 
+    | isFrictionless cr = (over crPos (+.+ momentum) $ setOldPos cr, g')
-        = (over crPos (+.+ momentum) $ setOldPos cr, g')
+    | otherwise = case cr ^? crStance . carriage of
-    | otherwise 
+        Just (Walking x y) 
-        = case cr ^? crStance . carriage of
+            -> (set (crStance . carriage) (Walking ((x+y)`mod`120) 0) $ setOldPos cr
-            Just (Walking x y) 
+                , g)
-                -> (set (crStance . carriage) (Walking ((x+y)`mod`120) 0)
+        _  -> (set (crStance . carriage) (Walking 0 0) $ setOldPos cr
-                    $ setOldPos
+                , g)
-                    cr, g)
-            _  -> (set (crStance . carriage) (Walking 0 0)
-                    $ setOldPos
-                    cr, g)
   where
     momentum' = 0.98 *.* (_crPos cr -.- _crOldPos cr)
     momentum'' | magV momentum' > 1 = 1 *.* normalizeV momentum'
@@ -180,25 +174,30 @@ isFrictionless cr = case cr ^? crStance . carriage of
 
 updateReloadCounter :: Creature -> Creature
 updateReloadCounter cr = over (crInv . ix iSel . itUseTime) decreaseToZero
-                            . over (crInv . ix iSel . wpReloadState) decreaseToZero
+    . over (crInv . ix iSel . wpReloadState) decreaseToZero
-                            $ cr
+    $ cr
-     where iSel = _crInvSel cr 
+  where 
+    iSel = _crInvSel cr 
 
 decreaseToZero :: Int -> Int
-decreaseToZero x | x > 0     = x - 1
+decreaseToZero x = max 0 (x - 1) 
-                 | otherwise = 0
 
 onDeath :: (Creature -> World -> World) -> CRUpdate -> CRUpdate
 onDeath h u w (f,g) cr 
     | _crHP cr > 0 = u w (f,g) cr
     | otherwise    = ( ( h cr . f, g ) , Nothing )
 
-updateBarrel :: 
+updateBarrel 
-    World -> (World -> World,StdGen) -> Creature -> ((World -> World , StdGen), Maybe Creature)
+    :: World 
-updateBarrel w (f,g) cr | _crHP cr > 0 = ((f, g), newCr)
+    -> (World -> World,StdGen) 
-                        | otherwise   = ((f, g), Nothing)
+    -> Creature 
-    where damages = _crDamage $ _crState cr
+    -> ((World -> World , StdGen), Maybe Creature)
-          newCr = Just $ doDamage cr
+updateBarrel w (f,g) cr 
+    | _crHP cr > 0 = ((f, g), newCr)
+    | otherwise   = ((f, g), Nothing)
+  where 
+    damages = _crDamage $ _crState cr
+    newCr = Just $ doDamage cr
 
 -- it is easy to leave off the "f" here 
 -- should find some better way of doing all this that is less prone to error
@@ -207,29 +206,30 @@ updateExpBarrel ::
 updateExpBarrel w (f,g) cr 
     | _crHP cr > 0 = ((f . foldr (.) id pierceSparks . hiss, g'), newCr)
     | otherwise   = ((f . makeExplosionAt (_crPos cr) . stopSounds , g'), Nothing)
-    where damages = _crDamage $ _crState cr
+  where 
-          pierceSparks :: [World -> World]
+    damages = _crDamage $ _crState cr
-          pierceSparks 
+    pierceSparks :: [World -> World]
-            = zipWith4 (\p a colid time-> (createBarrelSpark time colid (_crPos cr +.+ p) (a + argV p)) 
+    pierceSparks 
-                                                (Just $ _crID cr))
+      = zipWith4 (\p a colid time-> (createBarrelSpark time colid (_crPos cr +.+ p) (a + argV p)) 
-                                  poss as colids times
+                                          (Just $ _crID cr))
-          as =  randomRs (-0.7,0.7) $ g
+                            poss as colids times
-          colids = randomRs (0,11) $ g
+    as =  randomRs (-0.7,0.7) $ g
-          times = randomRs (2,5) $ g
+    colids = randomRs (0,11) $ g
-          (g',_) = split g
+    times = randomRs (2,5) $ g
-          poss = _piercedPoints $ _crSpState $ _crState cr
+    (g',_) = split g
-          --newCr = Just $ doDamage $ applyFuseDamage cr -- $ foldr perforate cr damages
+    poss = _piercedPoints $ _crSpState $ _crState cr
-          newCr = Just $ applyFuseDamage $ set (crState . crDamage) [] $ damToExpBarrel damages cr
+    --newCr = Just $ doDamage $ applyFuseDamage cr -- $ foldr perforate cr damages
-          perforate :: DamageType -> Creature -> Creature
+    newCr = Just $ applyFuseDamage $ set (crState . crDamage) [] $ damToExpBarrel damages cr
-          perforate (Piercing amount sp int ep) cr = over (crState . crSpState . piercedPoints)
+    perforate :: DamageType -> Creature -> Creature
-                                                            ((:) $ int -.- _crPos cr) cr
+    perforate (Piercing amount sp int ep) cr = over (crState . crSpState . piercedPoints)
-          perforate _ cr = cr
+                                                      ((:) $ int -.- _crPos cr) cr
-          applyFuseDamage cr = over crHP (\hp -> hp - length (_piercedPoints 
+    perforate _ cr = cr
-                                                             $ _crSpState $ _crState cr)) 
+    applyFuseDamage cr = over crHP (\hp -> hp - length (_piercedPoints 
-                                         cr
+                                                       $ _crSpState $ _crState cr)) 
-          hiss | poss == [] = id
+                                   cr
-               | otherwise  = soundMultiFrom [BarrelHiss 0,BarrelHiss 1] 41 50 1
+    hiss | poss == [] = id
-          stopSounds = stopSoundFrom (BarrelHiss 0) . stopSoundFrom (BarrelHiss 1)
+         | otherwise  = soundMultiFrom [BarrelHiss 0,BarrelHiss 1] 41 50 1
+    stopSounds = stopSoundFrom (BarrelHiss 0) . stopSoundFrom (BarrelHiss 1)
 
 damToExpBarrel :: [DamageType] -> Creature -> Creature
 damToExpBarrel ds cr = foldr damToExpBarrel' (foldr damToExpBarrel' cr pierceDam) otherDam

src/Dodge/Creature/State/Data.hs

@@ -6,17 +6,16 @@ import Geometry
 import Dodge.Data.DamageType
 import Dodge.Creature.Impulse.Data
 import Dodge.Creature.Stance.Data
+import Picture.Data
 
 import Control.Lens
 
 data CreatureState = CrSt 
     { _goals    :: [[Impulse]]
-    , _faction :: Faction
     , _crDamage  :: [DamageType]
     , _crPastDamage :: [[DamageType]]
     , _crSpState :: CrSpState
     , _crDropsOnDeath :: CreatureDropType
-    , _crIsAnimate  :: Bool
     }
 
 data CreatureDropType
@@ -36,6 +35,8 @@ data Faction
     | ChaseCritters
     | SpawnedBy Int
     | NoFaction
+    | ColorFaction Color
+    | PlayerFaction
   deriving (Eq,Show)
 
 makeLenses ''CreatureState

src/Dodge/Creature/Test.hs

@@ -0,0 +1,54 @@
+{- |
+Module testing for properties of creatures, whether they are reloading, etc.
+Each function takes the world and a creature and returns a bool.
+Note that the creature NEED NOT be the same as the creature with that id in the world, 
+in fact in some cases a creature with that id may not even exist.
+-}
+module Dodge.Creature.Test
+    where
+import Dodge.Data
+import Dodge.Base.Collide
+import Dodge.Creature.Stance.Data
+import Geometry
+import SameConstr
+
+import Data.List (find)
+import Data.Maybe
+import qualified Data.IntMap.Strict as IM
+import Control.Lens
+
+andTest :: (a -> Bool) -> (a -> Bool) -> a -> Bool
+andTest f g a = f a && g a
+
+onBoth :: (a -> b -> c) -> (d -> a) -> (d -> b) -> d -> c
+onBoth f g h x = f (g x) (h x)
+
+crIsReloading :: (World, Creature) -> Bool
+crIsReloading (w,cr) = case cr ^? crInv . ix (_crInvSel cr) . wpReloadState of
+    Just t -> t > 0
+    _ -> False
+
+crCanSeeCID :: Int -> (World, Creature) -> Bool
+crCanSeeCID cid (w,cr) = hasLOS (_crPos cr) (_crPos $ _creatures w IM.! cid) w
+
+crIsAiming :: (World,Creature) -> Bool
+crIsAiming (_,cr) = _posture (_crStance cr) == Aiming
+
+crHasTarget :: (World,Creature) -> Bool
+crHasTarget (_,cr) = isJust $ cr ^? crTarget . _Just
+
+crHasTargetLOS :: (World,Creature) -> Bool
+crHasTargetLOS (w,cr) = case cr ^? crTarget . _Just of
+    Just i -> crCanSeeCID i (w,cr) 
+    Nothing -> False
+
+crStratConMatches :: Strategy -> (World,Creature) -> Bool
+crStratConMatches strat (_,cr) = eqConstr strat (_crStrategy $ _crActionPlan cr)
+
+crAwayFromPost :: (World,Creature) -> Bool
+crAwayFromPost (_,cr) = case find sentinelGoal $ _crGoal $ _crActionPlan cr of
+    Just (SentinelAt p dir) -> dist p (_crPos cr) > 15
+    _ -> False
+  where
+    sentinelGoal (SentinelAt p dir) = True
+    sentinelGoal _ = False

src/Dodge/Data.hs

@@ -6,6 +6,7 @@ circular imports are probably not a good idea.
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE StrictData #-}
+{-# LANGUAGE DeriveGeneric #-}
 module Dodge.Data 
     ( module Dodge.Data
     , module Dodge.Data.DamageType
@@ -33,9 +34,11 @@ import Geometry.Data
 import Sound.Data
 import qualified DoubleStack as DS
 
+import GHC.Generics
 import Control.Lens
 import Control.Monad.State
 import System.Random
+import Data.Data
 import Data.Graph.Inductive
 import Data.Int (Int16)
 import qualified Data.Set as S
@@ -151,11 +154,13 @@ data Creature = Creature
     , _crCorpse         :: Picture
     , _crApplyDamage    :: [DamageType] -> Creature -> (World -> World,Creature)
     , _crStance         :: Stance
-    , _crRationality    :: Rationality
+    , _crActionPlan     :: ActionPlan
     , _crMeleeCooldown  :: Maybe Int
     , _crAwakeLevel     :: AwakeLevel
     , _crAttentionDir   :: AttentionDir
     , _crAwarenessLevel :: IM.IntMap AwarenessLevel
+    , _crFaction        :: Faction
+    , _crTarget         :: Maybe Int
     }
 data WorldState 
     = DoorNumOpen Int 
@@ -443,6 +448,138 @@ data ForceField = FF
     }
 data FFState = FFDestroyable { _ffsHP :: Int }
 
+data ActionPlan
+    = Inanimate
+    | ActionPlan
+        {_crImpulse     :: [Impulse]
+        ,_crAction      :: [Action]
+        ,_crStrategy    :: Strategy
+        ,_crGoal        :: [Goal]
+        }
+data Impulse
+    = Move Point2
+    | MoveForward Float
+    | StepForward
+    | Turn Float
+    | RandomTurn Float
+    | TurnToward Point2 Float
+    | TurnTo Point2
+    | UseItem
+    | SwitchToItem Int
+    | DropItem
+    | PickupNearby Int
+    | UseWorldObject Int
+    | Bark -- placeholder for various communication types
+    | UseIntrinsicAbility
+    | Melee Int
+    | ChangePosture Posture
+    | MakeSound Int
+    | ChangeStrategy Strategy
+    | AddGoal Goal
+    | ArbitraryCreatureImpulse (World -> Creature -> Creature) 
+--  deriving (Eq,Ord,Show)
+data Action
+    = Attack 
+        {_attackTargetID :: Int}
+    | AimAtCloseSlow 
+        {_targetID :: Int 
+        ,_targetSeenAt :: Point2 
+        ,_aimSpeed :: Float 
+        ,_slowAimSpeed :: Float
+        ,_slowAimAngle :: Float
+        }
+    | MeleeAttack 
+        {_meleeAttackLastSeen :: Point2 
+        ,_meleeAttackTargetID :: Int
+        }
+    | PathTo 
+        {_pathToPoint :: Point2
+        }
+    | FleeFrom 
+        {_fleeFromCID :: Int
+        }
+    | HealSelf
+    | DefendSelf
+    | Protect 
+        {_protectCID :: Int
+        }
+    | SearchFor 
+        {_searchForCID :: Int
+        }
+    | Search
+    | PickupItem 
+        {_pickupItemID :: Int
+        }
+    | ShootTillEmpty
+    | ImpulsesList 
+        {_impulsesListList :: [[Impulse]]
+        }
+    | DoImpulses 
+        {_doImpulsesList :: [Impulse]
+        }
+    | DrawWeapon
+    | HolsterWeapon
+    | WaitThen 
+        {_waitThenTimer :: Int 
+        ,_waitThenAction :: Action
+        }
+    | DoActionWhile 
+        {_doActionWhileAction :: Action 
+        ,_doActionWhileCondition :: ( (World, Creature) -> Bool)
+        }
+    | DoActionIfElse 
+        {_doActionIfElseIfAction :: Action 
+        ,_doActionIfElseCondition :: ( (World, Creature) -> Bool) 
+        ,_doActionIfElseElseAction :: Action
+        }
+    | DoActionWhileThen 
+        {_doActionWhileThenDo :: Action 
+        ,_doActionWhileThenCondition :: ( (World, Creature) -> Bool) 
+        ,_doActionWhileThenThen :: Action
+        }
+    | DoActions 
+        {_doActionsList :: [Action]
+        }
+    | DoActionOnce 
+        {_doActionOnceAction :: Action
+        }
+    | DoActionThen 
+        {_doActionThenFirst :: Action 
+        ,_doActionThenSecond :: Action
+        }
+    | DoGuardActions 
+        {_doGuardActionsList :: [( (World, Creature) -> Bool, Action, Maybe Action)]
+        }
+    | DoReplicateThen 
+        {_doReplicateThenDo :: Action 
+        ,_doReplicateThenTimes :: Int 
+        ,_doReplicateThenAfter :: Action
+        }
+    | LeadTarget
+        {_leadTargetBy :: Point2
+        }
+    | NoAction
+    | StartSentinelPost
+  deriving (Generic)
+--  deriving (Eq,Ord,Show)
+data Strategy
+    = Flank Int
+    | Ambush Int
+    | Lure Int Point2
+    | Patrol [Point2]
+    | ShootAt Int
+    | FollowImpulses
+    | WatchAndWait
+    | StrategyActions [Action] Strategy
+    | GetTo Point2
+    | Reload
+  deriving (Generic)
+--  deriving (Eq,Ord,Show)
+data Goal
+    = LiveLongAndProsper
+    | Kill Int
+    | SentinelAt Point2 Float
+
 makeLenses ''World
 makeLenses ''Cloud
 makeLenses ''Creature
@@ -460,6 +597,9 @@ makeLenses ''ForceField
 makeLenses ''FFState
 makeLenses ''PressPlate
 makeLenses ''Button
+makeLenses ''ActionPlan
+makeLenses ''Impulse
+makeLenses ''Action
 
 numColor :: Int -> Color
 numColor 0  = (1,0,0,1) 

src/Dodge/Default.hs

@@ -91,20 +91,20 @@ defaultCreature = Creature
     , _crCorpse = onLayer CorpseLayer $ color (greyN 0.5) $ circleSolid 10
     , _crApplyDamage = defaultApplyDamage
     , _crStance = Stance {_carriage=Walking 0 0,_posture=AtEase}
-    , _crRationality = ImpulseRat []
+    , _crActionPlan = ActionPlan [] [] WatchAndWait [LiveLongAndProsper]
     , _crMeleeCooldown = Nothing
     , _crAwakeLevel = Vigilant
     , _crAttentionDir = AttentiveTo []
     , _crAwarenessLevel = IM.empty
+    , _crFaction = NoFaction
+    , _crTarget  = Nothing
     }
 defaultState = CrSt 
     { _goals = []
-    , _faction = NoFaction
     , _crDamage = []
     , _crPastDamage = []
     , _crSpState = GenCr
     , _crDropsOnDeath = DropAmount 1
-    , _crIsAnimate = True
     }
 defaultEquipment = Equipment
     { _itIdentity = Generic

src/Dodge/Floor.hs

@@ -50,7 +50,7 @@ roomTreex = do
             [[StartRoom]
             ,[Corridor]
             ,[SpecificRoom . pure . pure . Right $ roomGlassOctogon 400 
-                                                 & rmPS %~ (PS (0,0) 0 (PutCrit miniGunCrit') :)
+                                                 & rmPS %~ (PS (0,-300) 0 (PutCrit multGunCrit) :)
              ]
             ,[Corridor]
             ,[Corridor]

src/Dodge/Item/Attachment.hs

@@ -36,11 +36,10 @@ charFiringStrat
     -> Int      -- ^ Creature id
     -> World 
     -> World
-charFiringStrat strats cid w =
+charFiringStrat strats cid w = case w ^? creatures . ix cid . crInv 
-    let Just (c :<| _) = w ^? creatures . ix cid . crInv 
+        . ix (_crInvSel $ _creatures w IM.! cid) . itAttachment . _Just . itCharMode of
-                        . ix (_crInvSel $ _creatures w IM.! cid) . itAttachment 
+    Just (c :<| _) -> fromJust (Prelude.lookup c strats) cid w
-                        . _Just . itCharMode
+    Nothing -> w
-    in fromJust (Prelude.lookup c strats) cid w
 
 increaseFuse 
     :: Int  -- ^ Old fuse time

src/Dodge/LevelGen/AutoDoor.hs

@@ -96,7 +96,7 @@ autoDoorPane (trigx,trigy) n closedPos openPos = Door
     a = fst closedPos
     b = snd closedPos
     dm w 
-        | any (crNearSeg 40 trigx trigy) $ IM.filter (_crIsAnimate . _crState) $ _creatures w
+        | any (crNearSeg 40 trigx trigy) $ IM.filter isAnimate $ _creatures w
             = flip (foldr changeZonedWall) zoneps $ over walls (IM.adjust openDoor n) w
         | otherwise 
             = flip (foldr changeZonedWall') zoneps $ over walls (IM.adjust closeDoor n) w

src/Dodge/SoundLogic.hs

@@ -42,8 +42,10 @@ module Dodge.SoundLogic (
     , smokeTrailSound 
     , foot1Sound 
     , foot2Sound 
+    , module Dodge.SoundLogic.Synonyms
     ) where
 import Dodge.Data
+import Dodge.SoundLogic.Synonyms
 import Sound.Data (SoundStatus (..))
 import Geometry.Vector
 import Geometry (dist)
@@ -180,26 +182,3 @@ soundMultiFrom (so:sos) sType time fadeTime w
 stopSoundFrom :: SoundOrigin -> World -> World
 stopSoundFrom so = over (sounds . ix so . soundTime) (fmap $ min 0)
 
-reloadSound,putDownSound,pickUpSound,fireSound,grenadeBang,healSound,teleSound,twoStepSlowSound :: Int
-clickSound = 1
-reloadSound = 2
-pickUpSound  = 4
-putDownSound = 5
-fireSound    = 6
-grenadeBang = 7
-tapQuiet = 8
-twoStepSound = 9
-healSound = 10
-doorSound = 11
-twoStepSlowSound = 12
-knifeSound = 13
-buzzSound = 14
-hitSound = 15
-autoGunSound = 16
-shotgunSound = 17
-teleSound = 18
-longGunSound = 19
-launcherSound = 20
-smokeTrailSound = 21
-foot1Sound = 22
-foot2Sound = 23

src/Dodge/SoundLogic/Synonyms.hs

@@ -0,0 +1,29 @@
+module Dodge.SoundLogic.Synonyms
+    where
+
+reloadSound,putDownSound,pickUpSound,fireSound,grenadeBang,healSound,teleSound,twoStepSlowSound :: Int
+clickSound = 1
+reloadSound = 2
+pickUpSound  = 4
+putDownSound = 5
+fireSound    = 6
+grenadeBang = 7
+tapQuiet = 8
+twoStepSound = 9
+healSound = 10
+doorSound = 11
+twoStepSlowSound = 12
+knifeSound = 13
+buzzSound = 14
+hitSound = 15
+autoGunSound = 16
+shotgunSound = 17
+teleSound = 18
+longGunSound = 19
+launcherSound = 20
+smokeTrailSound = 21
+foot1Sound = 22
+foot2Sound = 23
+
+drawWeaponSound = 4
+holsterWeaponSound = 5

src/Dodge/WallCreatureCollisions.hs

@@ -1,5 +1,7 @@
+{- |
+Deals with moving creature wall collisions.
+ -}
 module Dodge.WallCreatureCollisions where
--- imports {{{
 import Dodge.Data
 import Dodge.Creature.State.Data
 import Dodge.Base
@@ -43,12 +45,11 @@ wallBuffer = 3
 -- out from the wall
 -- this is then repeated if the point ends up on a new wall
 collideWalls :: Float -> Point2 -> [(Point2,Point2)] -> Point2 -> Point2
-collideWalls rad cp1 walls cp2
+collideWalls rad cp1 walls cp2 = case (listToMaybe.mapMaybe (pushOutFromWall rad cp2)) walls of
-    = case (listToMaybe.mapMaybe (pushOutFromWall rad cp2)) walls of
+    Nothing -> cp2
-            Nothing -> cp2
+    Just cp3 -> case (listToMaybe.reverse.mapMaybe (pushOutFromWall rad cp3)) walls of
-            Just cp3 -> case (listToMaybe.reverse.mapMaybe (pushOutFromWall rad cp3)) walls of
+        Nothing -> cp3
-                                         Nothing -> cp3
+        Just cp4 -> cp1
-                                         Just cp4 -> cp4
 
 -- pushes a point out from a list of walls
 -- if multiple new points occur, chooses the one closest to the orignal point
@@ -72,15 +73,16 @@ pushOrCrush wls cr = case mapMaybe (pushOutFromWall (_crRad cr) cpos) wls of
 -- assumes wall points are different
 pushOutFromWall :: Float -> Point2 -> (Point2,Point2) -> Maybe (Point2)
 pushOutFromWall rad cp2 (wp1,wp2) 
-            | isOnWall  = Just newP -- +.+ (1 *.* norm))
+    | isOnWall  = Just newP -- +.+ (1 *.* norm))
-            | otherwise = Nothing
+    | otherwise = Nothing
-    where norm = errorNormalizeV 61 $ vNormal (wp1 -.- wp2)
+  where 
-          wp1' = (rad *.* norm) +.+ wp1
+    norm = errorNormalizeV 61 $ vNormal (wp1 -.- wp2)
-          wp2' = (rad *.* norm) +.+ wp2
+    wp1' = (rad *.* norm) +.+ wp1
-          newP = errorClosestPointOnLine 5 wp1' wp2' cp2
+    wp2' = (rad *.* norm) +.+ wp2
-          isOnWall = circOnSegNoEndpoints wp1 wp2 cp2 rad
+    newP = errorClosestPointOnLine 5 wp1' wp2' cp2
-          isJust Nothing = False
+    isOnWall = circOnSegNoEndpoints wp1 wp2 cp2 rad
-          isJust _       = True
+    isJust Nothing = False
+    isJust _       = True
 
 pushOutFromCorners :: World -> Creature -> Creature
 pushOutFromCorners w cr = cr & crPos .~ newPos
@@ -93,8 +95,9 @@ collideCorners rad p1 ps p2 = foldr (intersectCirclePoint rad) p2 ps
 
 -- collide circles with points (outer corners)
 intersectCirclePoint :: Float -> Point2 -> Point2 -> Point2
-intersectCirclePoint rad p cCen | dist cCen p > rad = cCen
+intersectCirclePoint rad p cCen 
-                                | otherwise         = p +.+ (rad *.* errorNormalizeV 65 (cCen -.- p))
+    | dist cCen p > rad = cCen
+    | otherwise         = p +.+ (rad *.* errorNormalizeV 65 (cCen -.- p))
 
 checkPushThroughs :: Float -> Point2 -> [(Point2,Point2)] -> Point2 -> Point2
 checkPushThroughs rad cp1 walls cp2
@@ -102,12 +105,13 @@ checkPushThroughs rad cp1 walls cp2
 
 checkPushThrough :: Float -> Point2 -> Point2 -> (Point2,Point2) -> Maybe (Point2)
 checkPushThrough  rad cp1 cp2 (wp1,wp2) 
-            | isPushedThrough = intersectSegSeg' cp1 cp2 wp1 wp2
+    | isPushedThrough = intersectSegSeg' cp1 cp2 wp1 wp2
-            | otherwise = Nothing
+    | otherwise = Nothing
-    where norm = errorNormalizeV 61 $ vNormal (wp1 -.- wp2)
+  where
-          wp1' = (rad *.* norm) +.+ wp1
+    norm = errorNormalizeV 61 $ vNormal (wp1 -.- wp2)
-          wp2' = (rad *.* norm) +.+ wp2
+    wp1' = (rad *.* norm) +.+ wp1
-          newP = errorClosestPointOnLine 5 wp1' wp2' cp2
+    wp2' = (rad *.* norm) +.+ wp2
-          isPushedThrough = isRHS wp1 wp2 cp2 && isJust (intersectSegSeg' cp1 cp2 wp1 wp2)
+    newP = errorClosestPointOnLine 5 wp1' wp2' cp2
-          isJust Nothing = False
+    isPushedThrough = isRHS wp1 wp2 cp2 && isJust (intersectSegSeg' cp1 cp2 wp1 wp2)
-          isJust _       = True
+    isJust Nothing = False
+    isJust _       = True

src/Geometry.hs

@@ -268,6 +268,7 @@ nRaysRad n x = take n $ iterate (rotateV (2*pi/fromIntegral n)) (x,0)
 
 -- | Test whether an angle is to the left of another angle, according to the
 -- smallest change in rotation between them.
+-- This appears to sometimes fail if the angles are not normalized.
 isLeftOfA :: Float -> Float -> Bool
 isLeftOfA angle1 angle2 = 
     (angle1 - angle2 < pi && angle1 > angle2)

src/SameConstr.hs

@@ -0,0 +1,37 @@
+{-# LANGUAGE DefaultSignatures, TypeOperators, FlexibleContexts #-}
+{- | Pulled from
+https://stackoverflow.com/questions/10112733/haskell-simple-constructor-comparison-function
+ -}
+module SameConstr where
+
+import GHC.Generics
+import Data.Function (on)
+
+--class EqC a where
+--    eqConstr :: a -> a -> Bool
+--    default eqConstr :: (Generic a, GEqC (Rep a)) => a -> a -> Bool
+--    eqConstr = geqConstr `on` from
+
+eqConstr :: (Generic a, GEqC (Rep a)) => a -> a -> Bool
+eqConstr = geqConstr `on` from
+
+class GEqC f where
+  geqConstr :: f p -> f p -> Bool
+  {-# INLINE geqConstr #-}
+  geqConstr _ _ = True
+
+instance GEqC f => GEqC (M1 i c f) where
+  {-# INLINE geqConstr #-}
+  geqConstr (M1 x) (M1 y) = geqConstr x y
+
+instance GEqC (K1 i c)
+instance GEqC (f :*: g)
+instance GEqC U1
+instance GEqC V1
+
+instance (GEqC f, GEqC g) => GEqC (f :+: g) where
+  {-# INLINE geqConstr #-}
+  geqConstr (L1 x) (L1 y) = geqConstr x y
+  geqConstr (R1 x) (R1 y) = geqConstr x y
+  geqConstr _ _ = False
+