Refactoring

2021-05-03 23:59:20 +02:00
parent b826299cbd
commit e21178b688
20 changed files with 830 additions and 731 deletions
@@ -6,7 +6,7 @@ import Dodge.SoundLogic
 import Dodge.Creature.Action
 import Dodge.RandomHelp
 import Dodge.WorldEvent
-
+import Dodge.Creature.Picture
 import Geometry
 import Picture

@@ -18,18 +18,16 @@ import Data.Graph.Inductive.Graph
 import Data.Graph.Inductive.PatriciaTree
 import Data.Graph.Inductive.Query.SP
 import qualified Data.ByteString as B
-import Control.Lens
-import Control.Applicative
-import Control.Monad.State
-import Control.Monad
-
-import System.Random
 import qualified Data.Set as S
 import qualified Data.IntMap.Strict as IM
 import qualified Data.Map as M
-
-import Foreign.ForeignPtr
+import Control.Lens
+import Control.Applicative
+import Control.Monad
+import Control.Monad.State
 import Control.Concurrent
+import System.Random
+import Foreign.ForeignPtr

 factionIs :: Faction -> Creature -> Bool
 factionIs f c = (_faction $ _crState $ c) == f
@@ -845,7 +843,7 @@ launcherAI inRange outRange w (f,g) cr =
        (SetPosture pture:_) -> ((f,g), replaceAction [] $ set (crState . stance . posture) pture cr)
        (MoveByFor p 0:_) -> ((f,g'), replaceAction [] . crMvBy p $ cr)
        (MoveByFor p i:_) -> ((f,g'), replaceAction [MoveByFor p (i-1)] . crMvBy p $ cr)
-        (Fire:_) | collidePointWallsSimple cpos (cpos +.+ 40 *.* unitVectorAtAngle (_crDir cr)) 
+        (Fire:_) | pointHitsWalls cpos (cpos +.+ 40 *.* unitVectorAtAngle (_crDir cr)) 
                      (wallsAlongLine cpos (cpos +.+ 40 *.* unitVectorAtAngle (_crDir cr)) w) 
                              -> ((f,g),replaceAction [] cr)
                 | otherwise -> ((tryUseItem cid . f,g'), replaceAction [] cr)
@@ -1220,10 +1218,10 @@ twitchMissAI inRange outRange w (f,g) cr =
        (t,g') = randomR (fireRate+10,fireRate+15) g
        retreatPs = sortBy (compare `on` dist cpos) $ map f $ nRaysRad 8 400
            where f p = fromMaybe (ypos +.+ p) $ fmap fst
-                            $ collidePointWalls ypos (ypos +.+ p) (wallsAlongLine ypos (ypos +.+ p) w)
+                            $ reflectPointWalls ypos (ypos +.+ p) (wallsAlongLine ypos (ypos +.+ p) w)
        retreatP' = cpos +.+ 300 *.* (cpos -.- ypos)
        retreatP'' = fromMaybe retreatP' $ fmap fst
-                                         $ collidePointWalls ypos retreatP' 
+                                         $ reflectPointWalls ypos retreatP' 
                                         $ wallsAlongLine ypos retreatP' w
        retreatP = head $ sortBy (compare `on` (\p -> dist p ypos < 300)) $ retreatP'' : retreatPs
        fireActions = [TurnToward yposoff, Fire, TurnTo ypos, WaitFor t
@@ -1864,6 +1862,5 @@ spCrRadFac = 8^2


 ----------------
-circLine x = line [(0,0),(x,0)]

 sigmoid x = x/sqrt(1+x^2)
@@ -0,0 +1,211 @@
+{-# LANGUAGE TupleSections #-}
+{- | Basic collision detection for a moving point -}
+module Dodge.Base.Collide
+    where
+import Dodge.Data
+import Dodge.Base.Zone
+import Geometry
+
+import Data.List
+import Data.Maybe
+import qualified Data.IntMap.Strict as IM
+import Control.Lens
+
+hasLOS :: Point2 -> Point2 -> World -> Bool
+{-# INLINE hasLOS #-}
+hasLOS p1 p2 w = (not $ pointHitsWalls p1 p2 nearbyWalls) 
+  where 
+    nearbyWalls = wallsAlongLine p1 p2 w
+-- | looks for first collision of a point with walls
+-- if found, gives point and reflection velocity
+reflectPointWalls :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Point2)
+reflectPointWalls p1 p2 ws 
+    = listToMaybe 
+    . sortOn f 
+    . IM.elems 
+    $ IM.mapMaybe 
+        (( \(x:y:_) -> 
+            fmap ( (, reflectIn (x -.- y) (p2 -.- p1)) 
+                 . (+.+ errorNormalizeV 39 (vNormal (x -.- y)))
+                 ) 
+                 (intersectSegSeg' p1 p2 x y)
+         ) 
+        . _wlLine) ws
+  where 
+    f (a,_) = magV (p1 -.- a)
+-- | Looks for first collision of a point with walls.
+-- If found, gives point and reflection velocity, reflection damped in normal.
+reflectPointWallsDamped 
+    :: Float    -- ^ Damping factor, probably should be in (0,1)
+    -> Point2 
+    -> Point2 
+    -> IM.IntMap Wall 
+    -> Maybe (Point2,Point2)
+reflectPointWallsDamped dfact p1 p2 ws 
+    = listToMaybe 
+    . sortOn f 
+    . IM.elems 
+    $ IM.mapMaybe 
+        (( \(x:y:_) -> fmap ((, reflectInParam dfact (x -.- y) (p2 -.- p1)) 
+                            . (+.+ errorNormalizeV 40 (vNormal (x -.- y)))) 
+                                (intersectSegSeg' p1 p2 x y)) 
+         . _wlLine
+        ) ws
+  where 
+    f (a,_) = magV (p1 -.- a)
+-- | Test if a point collides with walls
+pointHitsWalls :: Point2 -> Point2 -> IM.IntMap Wall -> Bool
+pointHitsWalls p1 p2 
+    = any $ isJust . ( \(x:y:_) -> intersectSegSeg' p1 p2 x y) . _wlLine
+-- | Test if there something blocking a walk
+collidePointWalkable :: Point2 -> Point2 -> IM.IntMap Wall -> Bool
+collidePointWalkable p1 p2 ws 
+    = any (isJust . ( \(x:y:_) -> intersectSegSeg' p1 p2 x y) . _wlLine) 
+    $ IM.filter (fromMaybe True . (^? doorPathable)) ws
+
+furthestPointWalkable :: Point2 -> Point2 -> IM.IntMap Wall -> Point2
+furthestPointWalkable p1 p2 ws 
+    = fromMaybe p2
+    . listToMaybe
+    . sortOn (dist p1) 
+    . IM.elems 
+    $ IM.mapMaybe ( ( \(x:y:_) -> intersectSegSeg' p1 p2 x y) . _wlLine) ws
+
+collidePointIndirect :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe Point2
+{-# INLINE collidePointIndirect #-}
+collidePointIndirect p1 p2 ws 
+    = listToMaybe 
+    . sortOn (dist p1) 
+    . IM.elems 
+    . IM.mapMaybe ( ( \(x:y:_) -> intersectSegSeg' p1 p2 x y) . _wlLine) 
+    $ IM.filter (not . _wlIsSeeThrough) ws
+{- | Checks to see whether someone can fire bullets effectively between two points. 
+ - Not sure if this needs vision as well, need to make this uniform. -}
+collidePointFire :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe Point2
+collidePointFire p1 p2 ws 
+    = listToMaybe 
+    . sortOn (dist p1) 
+    . IM.elems 
+    . IM.mapMaybe ( ( \(x:y:_) -> intersectSegSeg' p1 p2 x y) . _wlLine ) 
+    $ IM.filter (\wl -> not (_wlIsSeeThrough wl && isJust (wl ^? blHP))) ws
+{- | Checks to see whether someone can fire bullets effectively between two points. 
+ - Not sure if this needs vision as well, need to make this uniform. -}
+collidePointFireVision :: Point2 -> Point2 -> IM.IntMap Wall -> Bool
+collidePointFireVision p1 p2 ws 
+    = any ( isJust . ( \(x:y:_) -> intersectSegSeg' p1 p2 x y) . _wlLine) 
+    $ IM.filter notBlockWindow ws
+  where 
+    notBlockWindow wl = case wl ^? blHP of
+        Just _  -> not $ _wlIsSeeThrough wl
+        Nothing -> True
+
+hasLOSIndirect :: Point2 -> Point2 -> World -> Bool
+hasLOSIndirect p1 p2 w = case collidePointIndirect p1 p2 $ wallsAlongLine p1 p2 w of 
+    Just _ -> False
+    Nothing -> True
+
+isWalkable :: Point2 -> Point2 -> World -> Bool
+isWalkable p1 p2 w = not $ collidePointWalkable p1 p2 nearbyWalls
+  where
+    nearbyWalls = wallsAlongLine p1 p2 w
+
+canSee :: Int -> Int -> World -> Bool
+canSee i j w = hasLOS p1 p2 w
+  where 
+    p1 = _crPos (_creatures w IM.! i)
+    p2 = _crPos (_creatures w IM.! j)
+    nearbyWalls = wallsAlongLine p1 p2 w
+
+canSeePoint :: Int -> Point2 -> World -> Bool
+canSeePoint i p w = hasLOS p1 p w
+  where
+    nearbyWalls = wallsAlongLine p1 p w
+    p1 = _crPos (_creatures w IM.! i)
+
+pathToPointFireable :: Int -> Point2 -> World -> Bool
+pathToPointFireable i p w 
+    = not 
+    . pointHitsWalls (_crPos (_creatures w IM.! i)) p
+    $ IM.filter (not . isJust . \wl -> wl ^? blHP) $ wallsAlongLine p1 p w
+  where 
+    p1 = _crPos (_creatures w IM.! i)
+
+canSeePointAll :: Int -> Point2 -> World -> Bool
+canSeePointAll i targPos w 
+    = and 
+    $ map (flip (canSeePoint i) w . (\p -> (targPos +.+ radius *.* p))) [(1,0),(0,1),(-1,0),(0,-1)]
+  where 
+    cr = _creatures w IM.! i
+    cpos = _crPos cr
+    radius = _crRad cr
+
+canSeeAny :: Int -> Int -> World -> Bool
+canSeeAny fromID toID w 
+    = or 
+    $ map (flip (canSeePoint fromID) w . (\p -> (cpos +.+ radius *.* p))) [(1,0),(0,1),(-1,0),(0,-1)]
+  where 
+    cr = _creatures w IM.! toID
+    cpos = _crPos cr
+    radius = _crRad cr
+
+canSeeAll :: Int -> Int -> World -> Bool
+canSeeAll fromID toID w 
+    = and 
+    $ map (flip (canSeePoint fromID) w . (\p -> (cpos +.+ radius *.* p))) [(1,0),(0,1),(-1,0),(0,-1)]
+  where 
+    cr = _creatures w IM.! toID
+    cpos = _crPos cr
+    radius = _crRad cr
+
+canWalk :: Int -> Int -> World -> Bool
+canWalk i j w = not $ collidePointWalkable ipos jpos $ wallsAlongLine ipos jpos w
+  where 
+    ipos = _crPos (_creatures w IM.! i)
+    jpos = _crPos (_creatures w IM.! j)
+
+canSeeIndirect :: Int -> Int -> World -> Bool
+canSeeIndirect i j w = not . isJust . collidePointIndirect ipos jpos $ wallsAlongLine ipos jpos w
+  where 
+    ipos = _crPos (_creatures w IM.! i)
+    jpos = _crPos (_creatures w IM.! j)
+    
+canSeeFire :: Point2 -> Point2 -> World -> Bool
+canSeeFire p p' w = not $ collidePointFireVision p p' $ wallsAlongLine p p' w
+
+canSeeFireVision :: Int -> Int -> World -> Bool
+canSeeFireVision i j w = canSeeFire ipos jpos w
+  where 
+    ipos = _crPos (_creatures w IM.! i)
+    jpos = _crPos (_creatures w IM.! j)
+{- | Test whether both of the outside lines between two creatures are blocked -}
+canSeeFireVisionAny :: Int -> Int -> World -> Bool
+canSeeFireVisionAny i j w 
+    = not 
+    $ collidePointFireVision (ipos +.+ ni) (jpos +.+ nj) 
+        (wallsAlongLine (ipos +.+ ni) (jpos +.+ nj) w)
+    && collidePointFireVision (ipos -.- ni) (jpos -.- nj) 
+        (wallsAlongLine (ipos -.- ni) (jpos -.- nj) w)
+  where
+    icr = _creatures w IM.! i
+    jcr = _creatures w IM.! j
+    ipos = _crPos icr
+    jpos = _crPos jcr
+    n = normalizeV $ vNormal $ ipos -.- jpos
+    ni = _crRad icr *.* n
+    nj = _crRad jcr *.* n
+{- | Test whether either of the outside lines between two creatures are blocked -}
+canSeeFireVisionAll :: Int -> Int -> World -> Bool
+canSeeFireVisionAll i j w 
+    = not 
+    $ collidePointFireVision (ipos +.+ ni) (jpos +.+ nj) 
+        (wallsAlongLine (ipos +.+ ni) (jpos +.+ nj) w)
+    || collidePointFireVision (ipos -.- ni) (jpos -.- nj) 
+        (wallsAlongLine (ipos -.- ni) (jpos -.- nj) w)
+  where
+    icr = _creatures w IM.! i
+    jcr = _creatures w IM.! j
+    ipos = _crPos icr
+    jpos = _crPos jcr
+    n = normalizeV $ vNormal $ ipos -.- jpos
+    ni = _crRad icr *.* n
+    nj = _crRad jcr *.* n
@@ -0,0 +1,24 @@
+{- | Getting the window size geometry. -}
+module Dodge.Base.Window
+    where
+import Dodge.Data
+import Dodge.Config.Data
+import Geometry
+
+screenPolygon :: World -> [Point2]
+screenPolygon w = [tr,tl,bl,br]
+  where 
+    scRot  = rotateV (_cameraRot w)
+    scZoom p | _cameraZoom w /= 0 = (1/_cameraZoom w) *.* p
+    scTran p = p +.+ _cameraCenter w
+    tr = scTran $ scRot $ scZoom ( halfWidth w, halfHeight w) 
+    tl = scTran $ scRot $ scZoom (-halfWidth w, halfHeight w) 
+    br = scTran $ scRot $ scZoom ( halfWidth w,-halfHeight w)
+    bl = scTran $ scRot $ scZoom (-halfWidth w,-halfHeight w)
+
+halfWidth,halfHeight :: World -> Float
+halfWidth w = getWindowX w / 2
+halfHeight w = getWindowY w / 2
+
+getWindowX = _windowX . _config
+getWindowY = _windowY . _config
@@ -0,0 +1,172 @@
+{- | Deals with the specific implementations of zoning for Dodge.
+ - These are not yet fixed down. -}
+module Dodge.Base.Zone
+    where
+import Dodge.Data
+import Dodge.Base.Window
+import Geometry
+
+import Data.Maybe
+import Data.List
+import Data.Bifunctor
+import qualified Data.IntMap.Strict as IM
+import qualified Data.IntSet as IS
+zoneSize :: Float
+zoneSize = 50
+--zoneSize = 100
+          
+floorHun :: Float -> Int
+floorHun x = floor $ x / zoneSize
+zoneOfPoint :: Point2 -> (Int,Int)
+zoneOfPoint (x,y) = (floorHun x, floorHun y)
+
+zoneNearPoint :: Point2 -> [(Int,Int)]
+zoneNearPoint (x',y') = [(a,b) | a<-[x-1,x,x+1] , b<-[y-1,y,y+1]]
+  where 
+    x = floorHun x'
+    y = floorHun y'
+
+zoneAroundPoint :: Point2 -> [(Int,Int)]
+zoneAroundPoint (x',y') = [(a,b) | a<-[x-3..x+3] , b<-[y-3..y+3]]
+  where 
+    x = floorHun x'
+    y = floorHun y'
+
+zoneAroundPoint' :: Int -> Point2 -> IM.IntMap IS.IntSet
+zoneAroundPoint' i (x',y') = IM.fromSet (const ys) xs
+  where 
+    x = floorHun x'
+    y = floorHun y'
+    xs = IS.fromAscList [x-i..x+i]
+    ys = IS.fromAscList [y-i..y+i]
+
+-- the laser seemed to be occasionally missing creatures,
+-- if this reoccurs, maybe change
+-- divide line factor from 2 to 1.5
+bres :: Point2 -> Point2 -> [(Int,Int)]
+bres a b = digitalLine (zoneOfPoint a) (zoneOfPoint b)
+
+bresx :: Point2 -> Point2 -> [(Int,Int)]
+bresx a b = digitalLine (x-1,y-1) (x'-1,y'-1)
+  where 
+    (x,y) = zoneOfPoint a
+    (x',y') = zoneOfPoint b
+
+zoneOfLine :: Point2 -> Point2 -> [(Int,Int)]
+zoneOfLine (aa,ab) (ba,bb) 
+    = nub 
+    . concatMap f 
+    $ digitalLine (zoneOfPoint (aa,ab)) (zoneOfPoint (ba,bb))
+  where 
+    f (x,y) = [(p,r) | p <-[x-1,x,x+1] , r<-[y-1,y,y+1]]
+
+zoneOfLineIntMap :: Point2 -> Point2 -> IM.IntMap IS.IntSet
+{-# INLINE zoneOfLineIntMap #-}
+zoneOfLineIntMap a b = expandLine $ digitalLine (x-1,y-1) (x'-1,y'-1)
+  where 
+    (x,y) = zoneOfPoint a
+    (x',y') = zoneOfPoint b
+
+expandLine :: [(Int,Int)] -> IM.IntMap IS.IntSet
+{-# INLINE expandLine #-}
+expandLine xs = IM.map expandSet 
+    $ IM.unionsWith IS.union [im, IM.mapKeysMonotonic (+1) im, IM.mapKeysMonotonic (+2) im]
+  where 
+    im = IM.fromListWith IS.union $ map (second IS.singleton) xs
+    -- the second was suggested by hlint, but it increases laziness, so might
+    -- not be ideal
+    expandSet s = IS.insert (mk+2) $ IS.insert (mk+1) s
+      where 
+        mk = IS.findMax s
+
+                        
+--zoneOfLine a b = concatMap zoneNearPoint $ divideLine (2 * zoneSize) a b
+--zoneOfLine a b = concatMap zoneNearPoint $ divideLine zoneSize a b
+
+zoneOfCircle :: Point2 -> Float -> [(Int,Int)]
+zoneOfCircle p r = concatMap zoneNearPoint $ divideCircle (1.5 * zoneSize) p r
+
+-- looking at this again, I am not convinced it deals correctly with the
+-- rotation of the world
+zoneOfScreen :: World -> [(Int,Int)]
+zoneOfScreen w = [(a,b) | a <- [x - n .. x + n]
+                        , b <- [y - n .. y + n]
+                 ]
+  where 
+    (x,y) = zoneOfPoint $ _cameraCenter w
+    n = ceiling $ wh / (_cameraZoom w * zoneSize)
+    wh = max (getWindowX w) (getWindowY w)
+
+zoneOfDoubleScreen :: World -> [(Int,Int)]
+zoneOfDoubleScreen w = [(a,b) | a <- [x - n .. x + n]
+                        , b <- [y - n .. y + n]
+                 ]
+  where 
+    (x,y) = zoneOfPoint $ _cameraCenter w
+    n = ceiling (wh / (_cameraZoom w * zoneSize)) * 2
+    wh = max (getWindowX w) (getWindowY w)
+
+zoneOfSight :: World -> [(Int,Int)]
+zoneOfSight w = 
+    [(a,b) 
+        | a <- [minimum xs .. maximum xs]
+        , b <- [minimum ys .. maximum ys]
+    ]
+  where 
+    (xs,ys) = unzip $ map zoneOfPoint $ screenPolygon w ++ [_cameraViewFrom w]
+
+wallsNearZones :: [(Int,Int)] -> World -> IM.IntMap Wall
+wallsNearZones is w = IM.unions [f b $ f a $ _wallsZone w | (a,b) <- is]
+  where 
+    f i m = case IM.lookup i m of 
+        Just val -> val
+        _        -> IM.empty
+
+ixZone :: IM.IntMap (IM.IntMap a) -> Point2 -> a
+ixZone z (x,y) = z IM.! floorHun x IM.! floorHun y
+
+ixNZ :: IM.IntMap (IM.IntMap a) -> Point2 -> [a]
+ixNZ z p = lookLookups (zoneNearPoint p) z
+
+lookLookup :: Int -> Int -> IM.IntMap (IM.IntMap a) -> Maybe a
+lookLookup i j z = case IM.lookup i z of
+    Just z' -> IM.lookup j z'
+    Nothing -> Nothing
+
+lookLookups :: [(Int,Int)] -> IM.IntMap (IM.IntMap a) -> [a]
+lookLookups xs z = mapMaybe (flip (uncurry lookLookup) z) xs
+
+-- possible BUG, was associated with thingsHitLongLine
+-- assumes _wallsZone is correct level generation
+-- there is certainly a problem somewhere here: it may be in the zoning, or
+-- within this function
+wallsAlongLine :: Point2 -> Point2 -> World -> IM.IntMap Wall
+{-# INLINE wallsAlongLine #-}
+wallsAlongLine a b w = IM.foldrWithKey' g IM.empty kps
+  where 
+    g x s = IM.union (IM.unions (IM.restrictKeys (f x $ _wallsZone w) s))
+    kps = zoneOfLineIntMap a b
+    f i m = case IM.lookup i m of 
+        Just val -> val
+        _        -> IM.empty
+
+wallsNearZone' :: IM.IntMap IS.IntSet -> World -> IM.IntMap Wall
+{-# INLINE wallsNearZone' #-}
+wallsNearZone' im w = IM.foldrWithKey' g IM.empty im
+    where g x s = IM.union (IM.unions (IM.restrictKeys (f x $ _wallsZone w) s))
+          f i m = case IM.lookup i m of Just val -> val
+                                        _        -> IM.empty
+
+
+wallsAlongCirc :: Point2 -> Float -> World -> IM.IntMap Wall
+wallsAlongCirc p r w =  IM.unions [f y $ f x $ _wallsZone w | (x,y) <- zoneOfCircle p r]
+    where f i m = case IM.lookup i m of Just val -> val
+                                        _        -> IM.empty
+
+wallsNearPoint :: Point2 -> World -> IM.IntMap Wall
+wallsNearPoint p w =  IM.unions [f b $ f a $ _wallsZone w | a<-[x-1,x,x+1] , b<-[y-1,y,y+1]]
+  where 
+    (x,y) = zoneOfPoint p
+    f i m = case IM.lookup i m of 
+        Just val -> val
+        _ -> IM.empty
@@ -13,8 +13,10 @@ import Dodge.WorldEvent.Cloud
 import Dodge.Creature.YourControl
 import Dodge.Creature.Inanimate
 import Dodge.Creature.State
+import Dodge.Creature.Picture
 import Dodge.Item
 import Dodge.Picture.Layer
+import Dodge.Creature.Picture
 import Picture
 import Geometry

@@ -37,15 +39,12 @@ import qualified Data.Map as M
 import Foreign.ForeignPtr
 import Control.Concurrent

-colouredEnemy col = pictures [color col $ circleSolid 10, circLine 10]
-
 spawnerCrit :: Creature
 spawnerCrit = defaultCreature
    { _crUpdate = stateUpdate $ spawnerAI chaseCrit
    , _crHP = 300
    , _crPict = basicCrPict blue
-    , _crState = defaultState {_goals = [[WaitFor 0]]
-                            }
+    , _crState = defaultState {_goals = [[WaitFor 0]] }
    , _crInv = IM.empty -- IM.fromList [(0,frontArmour)]
    }
 smallChaseCrit :: Creature
@@ -54,8 +53,10 @@ smallChaseCrit = defaultCreature
    , _crHP = 1
    , _crRad = 4
    , _crPict = basicCrPict green
-    , _crState = defaultState {_goals = [[Wait]]
-                            ,_faction = ChaseCritters}
+    , _crState = defaultState 
+        {_goals = [[Wait]]
+        ,_faction = ChaseCritters
+        }
    , _crInv = IM.empty -- IM.fromList [(0,frontArmour)]
    , _crCorpse = onLayer CorpseLayer $ color (greyN 0.5) $ circleSolid 4
    }
@@ -64,8 +65,10 @@ chaseCrit = defaultCreature
    { _crUpdate = stateUpdate chaseAI
    , _crHP = 300
    , _crPict = basicCrPict green
-    , _crState = defaultState {_goals = [[Wait]]
-                            ,_faction = ChaseCritters}
+    , _crState = defaultState 
+        {_goals = [[Wait]]
+        ,_faction = ChaseCritters
+        }
    , _crInv = IM.empty 
    }
 armourChaseCrit :: Creature
@@ -142,40 +145,17 @@ pistolCrit = defaultCreature
 autoCrit :: Creature
 autoCrit = defaultCreature
    { _crPict = basicCrPict red
-    --, _crUpdate =  checkDeadStopSound n . shooterFootsteps n . makeStateAI autoShooterAI n
    , _crUpdate = stateUpdate  basicShooterAI
-    --, _crUpdate = shooterFootsteps n . makeStateAI autoShooterAI n
    , _crInv = IM.fromList [(0,autoGun),(1,medkit 100)]
    , _crInvSel = 0
    , _crRad = 10
-    --, _crState = ShooterWait
    , _crState = defaultState {_goals = [[InitGuard]]}
    , _crHP = 300
    }
 addArmour :: Creature -> Creature
 addArmour = over crInv insarmour
-    where insarmour xs = IM.insert i frontArmour xs
-            where i = newKey xs
-
-equipOnTop :: (Creature -> Picture) -> Creature -> Picture
--equipOnTop f cr = onLayer CrLayer $ pictures $ fst (drawEquipment cr) ++ [f cr] ++ snd (drawEquipment cr)
-equipOnTop f cr = pictures [onLayer CrLayer (f cr) , drawEquipment cr]
-
-drawEquipment :: Creature -> Picture
-drawEquipment cr = pictures $ map f $ IM.toList (_crInv cr)
-    where f (i,it) = case it ^? itEquipPict of
-                        Just g -> g cr i
-                        _      -> blank
-
--drawEquipment :: Creature -> ([Picture],[Picture])
--drawEquipment cr = (map fst p1, map fst p2)
--     where f (k,it) = join $ (it ^? itEquipPict) <*> (pure cr) <*> (pure k)
--           picts = sortBy (compare `on` snd) $ mapMaybe f $ IM.toList (_crInv cr)
--           (p1,p2) = partition (\ x -> snd x < 0) picts
-
-frontArmouredPict = const $ pictures [ color (greyN 0.8) $ circleSolid 20
-                             , color red $ circLine 20
-                             ]
+  where 
+    insarmour xs = IM.insert (newKey xs) frontArmour xs

 --packCrits :: (Int -> World -> World) -> [Int] -> [Creature]
 --packCrits ai is = [(defaultCreature i)
@@ -220,27 +200,7 @@ frontArmouredPict = const $ pictures [ color (greyN 0.8) $ circleSolid 20
 --                  , line [(-3,3),(3,-3)]
 --                  , line [(0,-3),(0,3)]
 --                  ]
-
-flamerPict = const $ pictures [color (light $ light $ light $ dim blue) $ circleSolid 10, circLine 10]
-
-
-
-goalPict cr = let r = _crRad cr in case _crState cr of
-    CrSt {_goals = gls ,_crDamage = crDam } 
--            | crDam > _crHP cr -> color white $ circleSolid r
-            | otherwise        -> case head gls of
-                        [] -> sizeColEnemy r white
-                        (MoveToFor p i:_) -> dGoals $ sizeColEnemy r green
-                        (WaitFor x:_) -> dGoals $ sizeColEnemy r yellow
-                        (FireAt p:_) -> dGoals $ sizeColEnemy r red
-                        (Reload:_) -> dGoals $ sizeColEnemy r orange
-                        (PathTo p:_) -> dGoals $ sizeColEnemy r cyan
-                        (SubPathTo p i _:_) -> dGoals $ sizeColEnemy r blue
-                        (Search i:_) -> dGoals $ sizeColEnemy r black
-                        _ -> dGoals $ sizeColEnemy r magenta
-                    where dGoals p = pictures [p, rotate (0 - _crDir cr) $ scale 0.1 0.1 $ color white $ text $ show gls]
-    _                  -> sizeColEnemy r (light $ dim green)
-{-
+{- |
 The creature you control.
 ID 0.
 -}
@@ -254,12 +214,12 @@ startCr = defaultCreature
    , _crUpdate = stateUpdate yourControl
    , _crRad = 10
    , _crMass = 10
-    , _crHP = 1000000
+    , _crHP = 1000
    , _crMaxHP = 1500
    , _crInv = startInventory 
    , _crCorpse = onLayer CorpseLayer $ color (greyN 0.5) $ pictures [color (greyN 0.8) $ circleSolid 10, circLine 10]
    }
-{-
+{- |
 Items you start with.
 -}
 startInventory = IM.fromList (zip [0..20] 
@@ -287,31 +247,3 @@ startInventory = IM.fromList (zip [0..20]

 smokeGenGun = effectGun "smoke" $ \_ -> spawnSmokeAtCursor

-sizeEnemy col cr 
-    | pdam > 200      = color red $ circleSolid $ _crRad cr
-    | pdam > 100      = color white $ circleSolid $ _crRad cr
-    | mod pdam 2 == 1 = color white $ circleSolid $ _crRad cr
-    | otherwise       = pictures [color col $ circleSolid $ _crRad cr
-                                 , circLine $ _crRad cr ]
-  where 
-    pdam = sum $ concatMap (map _dmAmount) $ _crPastDamage $ _crState cr
-
-sizeColEnemy r col = pictures [color col $ circleSolid r, circLine r]
-
-basicCrPict :: Color -> Creature -> Picture
-basicCrPict col cr = pictures [ onLayer CrLayer $ bluntScale naked , drawEquipment cr]
-  where 
-    cdir = _crDir cr
-    naked | pdam > 200      = color red $ circleSolid $ _crRad cr
-          | pdam > 100      = color white $ circleSolid $ _crRad cr
-          | otherwise       = pictures [color col' $ circleSolid $ _crRad cr, circLine $ _crRad cr]
-    pastDams = _crPastDamage $ _crState cr
-    pdam = sum $ concatMap (map _dmAmount) $ pastDams
-    col' = light . light . light $ light col
-    bluntDam :: Maybe Point2
-    bluntDam = find isBluntDam (concat pastDams) >>= (\dm -> (-.-) <$> dm ^? dmFrom <*> dm ^? dmTo)
-    bluntScale = case fmap argV bluntDam of
-        Just a -> rotate (a + cdir) . scale 0.8 1.2 . rotate (negate $ cdir + a)
-        _   -> id
-    isBluntDam (Blunt {}) = True
-    isBluntDam _ = False
@@ -288,15 +288,15 @@ blinkAction
    :: Int      -- ^ Creature id
    -> World 
    -> World
-blinkAction n w = soundOnce teleSound 
-    $ set (creatures . ix n . crPos) p3
-    $ blinkShockwave n p3
-    $ inverseShockwaveAt cp 40 2 2 2 
-        w
+blinkAction n w 
+    = soundOnce teleSound 
+    . set (creatures . ix n . crPos) p3
+    . blinkShockwave n p3
+    $ inverseShockwaveAt cp 40 2 2 2 w
  where
    p1 = _cameraCenter w +.+ (1 / _cameraZoom w) *.* rotateV (_cameraRot w) (_mousePos w)
    cp = _crPos $ _creatures w IM.! n
-    p2 = collidePointWalls cp p1 $ wallsAlongLine cp p1 w
+    p2 = reflectPointWalls cp p1 $ wallsAlongLine cp p1 w
    r  = 1.5 * _crRad (_creatures w IM.! n)
    p3 = fromMaybe p1 (fmap ((\p -> moveAmountToward p r cp) . fst) p2)

@@ -0,0 +1,53 @@
+{- |
+Drawing of creatures. 
+Takes into account damage etc. -}
+module Dodge.Creature.Picture
+    ( basicCrPict
+    , circLine
+    ) where
+import Dodge.Data
+import Dodge.Picture.Layer
+import Picture
+import Geometry
+
+import Control.Lens
+import Data.List
+import qualified Data.IntMap.Strict as IM
+basicCrPict 
+    :: Color    -- ^ Creature color
+    -> Creature 
+    -> Picture
+basicCrPict col cr = pictures [ onLayer CrLayer . piercingMod $ bluntScale naked , drawEquipment cr]
+  where 
+    cdir = _crDir cr
+    naked 
+        | pdam > 200    = color red $ circleSolid $ _crRad cr
+        | pdam > 100    = color white $ circleSolid $ _crRad cr
+        | otherwise     = pictures [color col' $ circleSolid $ _crRad cr, circLine $ _crRad cr]
+    pastDams = _crPastDamage $ _crState cr
+    pdam = sum $ concatMap (map _dmAmount) $ pastDams
+    col' = light . light . light $ light col
+    bluntDam :: Maybe Point2
+    bluntDam = find isBluntDam (concat pastDams) >>= (\dm -> (-.-) <$> dm ^? dmFrom <*> dm ^? dmTo)
+    bluntScale = case fmap argV bluntDam of
+        Just a -> rotate (a + cdir) . scale 0.8 1.2 . rotate (negate $ cdir + a)
+        _   -> id
+    isBluntDam (Blunt {}) = True
+    isBluntDam _ = False
+    piercingDam = find isPiercingDam (concat pastDams) >>= (\dm -> (-.-) <$> dm ^? dmFrom <*> dm ^? dmTo)
+    isPiercingDam (Piercing {}) = True
+    isPiercingDam _ = False
+    piercingMod = case fmap argV piercingDam of
+        Just a -> rotate (a + cdir) . scale 0.8 1.2 . rotate (negate $ cdir + a)
+        _   -> id
+
+drawEquipment 
+    :: Creature 
+    -> Picture
+drawEquipment cr = pictures $ map f $ IM.toList (_crInv cr)
+  where 
+    f (i,it) = case it ^? itEquipPict of
+        Just g -> g cr i
+        _      -> blank
+
+circLine x = line [(0,0),(x,0)]
@@ -416,7 +416,8 @@ data Either3 a b c = E3x1 a | E3x2 b | E3x3 c

 data Wall 
    = Wall 
-        { _wlLine :: [Point2] , _wlID :: Int 
+        { _wlLine :: [Point2] 
+        , _wlID :: Int 
        , _wlColor :: Color
        , _wlSeen :: Bool
        , _wlIsSeeThrough :: Bool
@@ -177,7 +177,7 @@ updateTractor colID time i w
    q = _pjVel pj
    p1 = _pjPos pj
    p' = _pjStartPos pj
-    p2 = maybe p' fst $ collidePointWalls p1 p' $ wallsNearPoint p' w
+    p2 = maybe p' fst $ reflectPointWalls p1 p' $ wallsNearPoint p' w
    p4 = vNormal p5
    p5 = errorNormalizeV 12 $ p2 -.- p1
    p3 = p1 +.+ p4
@@ -23,9 +23,19 @@ vvThickLine = lineOfThickness 6
 -- shit this is ugly
 lineOfThickness :: Float -> [Point2] -> Picture
 lineOfThickness t = pictures . f
-    where f (x:y:ys) 
-            | x == y = f (x:ys)
-            | otherwise 
-                     = polygon [x +.+ n x y, x -.- n x y, y -.- n x y, y +.+ n x y] : f (y:ys)
-          f _        = []
-          n a b      = (t*0.5) *.* errorNormalizeV 42 (vNormal (a -.- b))
+  where 
+    f (x:y:ys) 
+        | x == y = f (x:ys)
+        | otherwise = polygon [x +.+ n x y, x -.- n x y, y -.- n x y, y +.+ n x y] : f (y:ys)
+    f _   = []
+    n a b = (t*0.5) *.* errorNormalizeV 42 (vNormal (a -.- b))
+
+wedgeOfThickness :: Float -> Point2 -> Point2 -> Picture
+wedgeOfThickness t x y 
+    | x == y    = blank
+    | otherwise = pictures 
+        [uncurry translate x $ circleSolid (0.5*t)
+        ,polygon [x +.+ n x y, x -.- n x y, y]
+        ]
+  where 
+    n a b = (t*0.5) *.* errorNormalizeV 4200 (vNormal (a -.- b))
@@ -19,7 +19,7 @@ Lists are lexicographically ordered if input values are always less than 100.
 Higher numbers will get placed on top of lower numbers.
 -}
 onLayerL :: [Int] -> Picture -> Picture
-onLayerL is = setDepth (1 - (sum $ zipWith (/) (map fromIntegral is) $ map (100 **) [1..]))
+onLayerL is = setDepth (1 - sum (zipWith (/) (map fromIntegral is) $ map (100 **) [1..]))

 {- | For depth testing, set layer values.
 -}
@@ -23,7 +23,7 @@ airlockOneWay n = Room
    , _rmLinks = lnks
    , _rmPath  = []
    , _rmPS    = [PS (0,15) 0 $ PutDoubleDoor col (not . cond) (0,0) (0,40)
-                 ,PS (0,75) 0 $ PutDoubleDoor col (cond)       (0,0) (0,40)
+                 ,PS (0,75) 0 $ PutDoubleDoor col cond         (0,0) (0,40)
                 ,PS (35,45) (pi/2) $ PutButton $ makeButton col (over worldState 
                                                                 (M.insert (DoorNumOpen n) True))
                 ]
@@ -60,7 +60,7 @@ airlock0 n = Room
                 ]
    , _rmPS    = 
        [PS (0,20) 0 $ PutDoubleDoor col (not . cond) (1,0) (39,0)
-        ,PS (0,80) 0 $ PutDoubleDoor col (cond)       (1,0) (39,0)
+        ,PS (0,80) 0 $ PutDoubleDoor col cond         (1,0) (39,0)
        ,PS (35,50) (pi/2) $ PutButton $ makeSwitch col 
                           (over worldState (M.insert (DoorNumOpen n) True))
                           (over worldState (M.insert (DoorNumOpen n) False))
@@ -66,7 +66,7 @@ randomMediumRoom = takeOne
    [ roomOctogon 300
    , roomCross 180 300
    , roomShuriken 200 300
-    , roomTwistCross 230 300 (0)
+    , roomTwistCross 230 300 0
    ]

 roomCross 
@@ -21,7 +21,7 @@ corridor = Room
    lnks = 
        [((20,70)  ,0)
        ,((20,70), pi/6)
-        ,((20,70), 0-pi/6)
+        ,((20,70), negate $ pi/6)
        ,((20,10)    ,pi)
        ]
 corridorN :: Room
@@ -40,7 +40,7 @@ twinSlowDoorRoom drID w h x = Room
    , _rmPS     = 
        [ PS (0,h/2) 0 putLamp
        , PS (25,5) 0 putLamp
-        , PS (negate $ 25,5) 0 putLamp
+        , PS (negate 25,5) 0 putLamp
        , PS (0,0) 0 $ PutDoor col (not . cond) drL
        , PS (0,0) 0 $ PutDoor col (not . cond) drR
        , PS (0,h-5) pi $ PutButton $ makeButton col 
@@ -57,7 +57,7 @@ twinSlowDoorRoom drID w h x = Room
        [0..nDrp]
    drR = fmap ((\h' -> ((-x,-h'),(-x,h-h'))) . (* h) . (/ fromIntegral nDrp) . fromIntegral) 
        [0..nDrp]
-    nDrp = ceiling $ h
+    nDrp = ceiling h
    cond w = or $ M.lookup (DoorNumOpen drID) (_worldState w)
    col = dim $ dim $ bright red

@@ -82,31 +82,34 @@ slowDoorRoom = do
        ,( (x/2+50,5),0)
        ]
     let n = 25
-     xs <- sequence $ replicate n $ state $ randomR (10,x-10)
-     ys <- sequence $ replicate n $ state $ randomR (h+20,y)
-     rs <- sequence $ replicate n $ state $ randomR (0,2*pi)
+     xs <- replicateM n $ state $ randomR (10,x-10)
+     ys <- replicateM n $ state $ randomR (h+20,y)
+     rs <- replicateM n $ state $ randomR (0,2*pi)
     let ps = zip xs ys
-     xs' <- sequence $ replicate 5 $ state $ randomR (10,x-10)
-     ys' <- sequence $ replicate 5 $ state $ randomR (h+20,y)
+     xs' <- replicateM 5 $ state $ randomR (10,x-10)
+     ys' <- replicateM 5 $ state $ randomR (h+20,y)
     let crits = zipWith (\p r -> PS p r randC1) ps rs
         lsources = [PS (x/2,30) 0 putLamp, PS (x/2,y-30) 0 putLamp]
-     let barrels = zipWith (\x y -> PS (x,y) 0 $ PutCrit explosiveBarrel) xs' ys'
-     let pillarsa = []
-     let pillarsb = putBlockRect (x/5-20) (x/5+20) (h/2-20) (h/2+20)
-                   ++ putBlockRect (2*x/5-20) (2*x/5+20) (h/2-20) (h/2+20)
-                   ++ putBlockRect (3*x/5-20) (3*x/5+20) (h/2-20) (h/2+20)
-                   ++ putBlockRect (4*x/5-20) (4*x/5+20) (h/2-20) (h/2+20)
-     let pillarsc = putBlockRect (x/3-20) (x/3+20) (h/2-20) (h/2+20)
-                   ++ putBlockRect (2*x/3-20) (2*x/3+20) (h/2-20) (h/2+20)
+         barrels = zipWith (\x y -> PS (x,y) 0 $ PutCrit explosiveBarrel) xs' ys'
+         pillarsa = []
+         pillarsb = putBlockRect (x/5-20) (x/5+20) (h/2-20) (h/2+20)
+            ++ putBlockRect (2*x/5-20) (2*x/5+20) (h/2-20) (h/2+20)
+            ++ putBlockRect (3*x/5-20) (3*x/5+20) (h/2-20) (h/2+20)
+            ++ putBlockRect (4*x/5-20) (4*x/5+20) (h/2-20) (h/2+20)
+         pillarsc = putBlockRect (x/3-20) (x/3+20) (h/2-20) (h/2+20)
+            ++ putBlockRect (2*x/3-20) (2*x/3+20) (h/2-20) (h/2+20)
     pillars <- takeOne [pillarsa, pillarsb, pillarsc]
     let cond x = (snd . fst) x > h + 40
-     let cond2 x = (snd . fst) x < h - 40
+         cond2 x = (snd . fst) x < h - 40
     but <- takeOne [PutBtDoor (dim $ light red) butPos butRot (0,h) (x,h)
                  --  ,PutSwitchDoor (dim $ light red) butPos butRot (0,h) (x,h)
                    ]
-     fmap connectRoom (filterLinks cond =<< (changeLinkTo cond2
-                                             $ set rmPS ([PS (0,0) 0 but] ++ crits ++ pillars ++ barrels ++ lsources) 
-                                             $ roomRectAutoLinks x y
-                                             ))
+     fmap connectRoom 
+        (filterLinks cond =<< 
+            changeLinkTo cond2 
+                (set rmPS ([PS (0,0) 0 but] ++ crits ++ pillars ++ barrels ++ lsources) 
+                $ roomRectAutoLinks x y
+                )
+        )

-randC1 = RandPS $ takeOne $ map PutCrit $ (armourChaseCrit : replicate 50 chaseCrit)
+randC1 = RandPS $ takeOne $ map PutCrit $ armourChaseCrit : replicate 50 chaseCrit
@@ -62,9 +62,11 @@ roomRectAutoLinks :: Float -> Float -> Room
 roomRectAutoLinks x y = roomRect x y ((ceiling x - 40) `div` 60) ((ceiling y - 40) `div` 60)

 makeGrid :: Float -> Int -> Float -> Int -> [(Point2,Point2)]
-makeGrid x nx y ny = nub $ concatMap doublePair 
-                         $ concatMap (\p -> map (\(a,b) -> (p +.+ a,p +.+ b)) $ makeRect x y)
-                         $ gridPoints x nx y ny
+makeGrid x nx y ny 
+    = nub 
+    . concatMap doublePair 
+    . concatMap (\p -> map (\(a,b) -> (p +.+ a,p +.+ b)) $ makeRect x y)
+    $ gridPoints x nx y ny

 gridPoints :: Float -> Int -> Float -> Int -> [Point2]
 gridPoints x nx y ny = [(a,b) | a <- take nx $ scanl (+) 0 $ repeat x
@@ -230,7 +232,7 @@ centerVaultRoom n w h d = do
        nsDoors = rectNSWE (d + 20) (negate (d +20)) (-20) 20
        weDoors = rectNSWE 20 (-20) (d + 20) (negate (d +20)) 
        centerPoly = rectWdthHght (d - 20) (d - 20)
-        polys = centerPoly : nsDoors : weDoors : (take 4 $ iterate (map vNormal) northPoly)
+        polys = centerPoly : nsDoors : weDoors : take 4 (iterate (map vNormal) northPoly)
    return $ Room
        { _rmPolys  = polys
        , _rmLinks  = 
@@ -165,7 +165,7 @@ farWallDist cpos w = min (halfWidth w / (horizontalMax+50) ) (halfHeight w / (ve
    tRays = rotF [(y, maxViewDistance) | y <- zs]
    bRays = rotF [(y,-maxViewDistance) | y <- zs]
    rotF = map (h . (+.+) cpos . rotateV (_cameraRot w))
-    zs = takeWhile (< maxViewDistance) [-maxViewDistance,0 - 0.8*maxViewDistance..]
+    zs = takeWhile (< maxViewDistance) [-maxViewDistance,negate $ 0.8*maxViewDistance..]
    maxViewDistance = 800
    

@@ -63,11 +63,11 @@ makeExplosionAt
    :: Point2   -- ^ Position
    -> World 
    -> World
-makeExplosionAt p w = soundOncePos grenadeBang p
+makeExplosionAt p w 
+    = soundOncePos grenadeBang p
    . addFlames 
    . explosionFlashAt p
-    $ makeShockwaveAt [] p 50 10 1 white
-        w
+    $ makeShockwaveAt [] p 50 10 1 white w
  where 
    fVs  = replicateM 75 (randInCirc 1)  & evalState $ _randGen w
    fPs' = replicateM 75 (randInCirc 15) & evalState $ _randGen w
@@ -79,6 +79,5 @@ makeExplosionAt p w = soundOncePos grenadeBang p
    mF q v size time = makeFlameletTimed q v Nothing size time
    newFs = zipWith4 mF fPs (fmap (3 *.*) fVs') sizes times
    addFlames w = foldr ($) w newFs
-    pushAgainstWalls q = maybe q (uncurry (+.+)) 
-                                     $ collidePointWalls p q $ wallsNearPoint q w
+    pushAgainstWalls q = maybe q (uncurry (+.+)) $ reflectPointWalls p q $ wallsNearPoint q w

@@ -304,7 +304,7 @@ moveTeslaArc p d i w =
    sID  = newProjectileKey w
    q1 = last $ init ps'
    q2 = last ps'
-    hitWall = collidePointWalls q1 ((2 *.* q2) -.- q1) $ wallsNearPoint q1 w
+    hitWall = reflectPointWalls q1 ((2 *.* q2) -.- q1) $ wallsNearPoint q1 w
    (d1,_)  = randomR (-0.7,0.7) $ _randGen w
    sv = maybe (q2 -.- q1) snd hitWall

@@ -362,7 +362,7 @@ crOrWallSensitive p dir wlAttract w =
        . sortBy (compare `on` dist p)
        $ mapMaybe 
            ( fmap fst
-            . (\p1 -> collidePointWalls p p1 $ wallsNearPoint p w)
+            . (\p1 -> reflectPointWalls p p1 $ wallsNearPoint p w)
            . (+.+) p
            . (\d -> rotateV d (100,0))
            . (+ dir)
@@ -385,17 +385,18 @@ crOrWall p dir w = fromMaybe (E3x3 $ p +.+ rotateV dir (arcLen,0))
                                        $ catMaybes [cr,wlp]
  where 
    cr  = E3x1 <$> nearestCrInFront p dir 100 w
-    wlp = fmap E3x2 $ listToMaybe
-           $ sortBy (compare `on` dist p)
-           $ mapMaybe 
-               ( fmap fst
-               . (\p1 -> collidePointWalls p p1 $ wallsNearPoint p w)
-               . (+.+) p
-               . (\d -> rotateV d (100,0))
-               . (+) dir
-               )
-               [-(3*pi/8),-pi/4,-pi/8,0,pi/8,pi/4,3*pi/8]
-               --[-pi/4,-pi/8,0,pi/8,pi/4]
+    wlp = fmap E3x2 
+        $ listToMaybe
+        $ sortBy (compare `on` dist p)
+        $ mapMaybe 
+            ( fmap fst
+            . (\p1 -> reflectPointWalls p p1 $ wallsNearPoint p w)
+            . (+.+) p
+            . (\d -> rotateV d (100,0))
+            . (+) dir
+            )
+            [-(3*pi/8),-pi/4,-pi/8,0,pi/8,pi/4,3*pi/8]
+            --[-pi/4,-pi/8,0,pi/8,pi/4]
    g (E3x2 p1)  = 100 + dist p p1 -- tweak makes it more likely to hit crs first
    --g (E3x2 p1)  = dist p p1 - 100 -- tweak makes it more likely to hit walls first
    g (E3x1 cr1) = dist p $ _crPos cr1