diff --git a/ghcidOutput b/ghcidOutput index 8daf446c7..4639de1c1 100644 --- a/ghcidOutput +++ b/ghcidOutput @@ -1,105 +1 @@ -/home/justin/Haskell/loop/src/Polyhedra.hs:68:5: warning: [GHC-62161] [-Wincomplete-uni-patterns] - Pattern match(es) are non-exhaustive - In a pattern binding: - Patterns of type ‘[Point3]’ not matched: - [] - [_] - [_, _] - | -68 | (a:b:c:_) = xs - | ^^^^^^^^^^^^^^ -/home/justin/Haskell/loop/src/Polyhedra/Geodesic.hs:59:5: warning: [GHC-62161] [-Wincomplete-uni-patterns] - Pattern match(es) are non-exhaustive - In a pattern binding: - Patterns of type ‘[[a]]’ not matched: - [] - [_] - | -59 | (f0:f1:fs) = rotateTo ((== n) . head) vss - | ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -/home/justin/Haskell/loop/src/SimpleTrie.hs:36:13: warning: [GHC-62161] [-Wincomplete-uni-patterns] - Pattern match(es) are non-exhaustive - In a pattern binding: Patterns of type ‘[a]’ not matched: [] - | -36 | let (z : zs) = xs - | ^^^^^^^^^^^^^ -/home/justin/Haskell/loop/src/SimpleTrie.hs:45:13: warning: [GHC-62161] [-Wincomplete-uni-patterns] - Pattern match(es) are non-exhaustive - In a pattern binding: Patterns of type ‘[(a, c)]’ not matched: [] - | -45 | let ((z1, z2) : zs) = xs - | ^^^^^^^^^^^^^^^^^^^^ -/home/justin/Haskell/loop/src/Dodge/WdP2f.hs:12:13: warning: [GHC-62161] [-Wincomplete-uni-patterns] - Pattern match(es) are non-exhaustive - In a pattern binding: - Patterns of type ‘Maybe (Point2, Point2)’ not matched: Nothing - | -12 | let Just (a, b) = w ^? cWorld . lWorld . doors . ix drid . drPos - | ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -/home/justin/Haskell/loop/src/Dodge/Debug/Picture.hs:118:5: warning: [GHC-62161] [-Wincomplete-uni-patterns] - Pattern match(es) are non-exhaustive - In a pattern binding: Patterns of type ‘[Point2]’ not matched: [] - | -118 | (p : ps) = - | ^^^^^^^^^^... -/home/justin/Haskell/loop/src/Dodge/Debug/Picture.hs:302:5: warning: [GHC-62161] [-Wincomplete-uni-patterns] - Pattern match(es) are non-exhaustive - In a pattern binding: Patterns of type ‘[Point2]’ not matched: [] - | -302 | (x : xs) = w ^. wCam . camBoundBox - | ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -/home/justin/Haskell/loop/src/RandomHelp.hs:36:9: warning: [GHC-62161] [-Wincomplete-uni-patterns] - Pattern match(es) are non-exhaustive - In a pattern binding: - Patterns of type ‘([a], [a])’ not matched: (_, []) - | -36 | let (zs, w : ws) = splitAt i ys - | ^^^^^^^^^^^^^^^^^^^^^^^^^^^ -/home/justin/Haskell/loop/src/RandomHelp.hs:51:17: warning: [GHC-62161] [-Wincomplete-uni-patterns] - Pattern match(es) are non-exhaustive - In a pattern binding: - Patterns of type ‘([b], [b])’ not matched: (_, []) - | -51 | let (as, b : bs) = splitAt rand ys - | ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -/home/justin/Haskell/loop/src/Dodge/HeldUse.hs:177:5: warning: [GHC-62161] [-Wincomplete-uni-patterns] - Pattern match(es) are non-exhaustive - In a pattern binding: - Patterns of type ‘([Float], StdGen)’ not matched: - ([], _) - ([_], _) - ([_, _], _) - ([_, _, _], _) - | -177 | (a : b : c : d : _, g) = runState thestate $ _randGen w -- randomRs (2, 20) (_randGen w) - | ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -/home/justin/Haskell/loop/src/Tile.hs:36:5: warning: [GHC-62161] [-Wincomplete-uni-patterns] - Pattern match(es) are non-exhaustive - In a pattern binding: - Patterns of type ‘[Point2]’ not matched: - [] - [_] - | -36 | (c:d:_) = poly - | ^^^^^^^^^^^^^^ -/home/justin/Haskell/loop/src/Dodge/Room/RezBox.hs:54:22: warning: [GHC-47082] [-Woperator-whitespace-ext-conflict] - The prefix use of a ‘$’ would denote an untyped splice - were the TemplateHaskell extension enabled. - Suggested fix: Add whitespace after the ‘$’. - | -54 | shuffleLinks $(roomRectAutoLinks w h){_rmPmnts = []} - | ^ -/home/justin/Haskell/loop/src/Dodge/Room/RezBox.hs:120:44: warning: [GHC-47082] [-Woperator-whitespace-ext-conflict] - The prefix use of a ‘$’ would denote an untyped splice - were the TemplateHaskell extension enabled. - Suggested fix: Add whitespace after the ‘$’. - | -120 | let n = length $ filter bottomEdgeTest $_rmLinks centralRoom - | ^ -/home/justin/Haskell/loop/src/Dodge/Room/RezBox.hs:122:29: warning: [GHC-47082] [-Woperator-whitespace-ext-conflict] - The prefix use of a ‘$’ would denote an untyped splice - were the TemplateHaskell extension enabled. - Suggested fix: Add whitespace after the ‘$’. - | -122 | tToBTree "rezBoxes" $treeFromTrunk [rezBox thecol, door] $ - | ^ +All good (596 modules, at 10:48:32) diff --git a/src/Dodge/Debug/Picture.hs b/src/Dodge/Debug/Picture.hs index ee6fea96c..d99bc3f10 100644 --- a/src/Dodge/Debug/Picture.hs +++ b/src/Dodge/Debug/Picture.hs @@ -1,3 +1,4 @@ +{-# OPTIONS -Wno-incomplete-uni-patterns #-} module Dodge.Debug.Picture where import Control.Lens @@ -5,19 +6,21 @@ import Data.Foldable import qualified Data.Graph.Inductive as FGL import qualified Data.Map.Strict as M import Data.Maybe +import qualified Data.Set as S import Dodge.Base import Dodge.Creature.Picture.Awareness import Dodge.Data.Universe - import Dodge.GameRoom import Dodge.Graph import Dodge.Path import Dodge.Picture.SizeInvariant import Dodge.Render.InfoBox +import Dodge.Render.Label import Dodge.Render.List import Dodge.ShortShow import Dodge.SoundLogic.LoadSound import Dodge.Viewpoints +import Dodge.WorldEvent.ThingsHit import Dodge.Zoning import Dodge.Zoning.Base import Geometry @@ -28,9 +31,6 @@ import Picture import SDL (MouseButton (..)) import ShortShow import Sound.Data -import qualified Data.Set as S -import Dodge.Render.Label -import Dodge.WorldEvent.ThingsHit printPoint :: Point2 -> Picture printPoint p = color white $ uncurryV translate p $ fold [circle 3, scale 0.05 0.05 $ text (show p)] @@ -107,11 +107,13 @@ drawCollisionTest w = fromMaybe mempty $ do return $ setLayer DebugLayer (color orange $ line [a, b]) <> foldMap (drawCrossCol red . fst) (thingHit a b w) + -- <> foldMap (drawCross . _crPos) (crsNearSeg a b w) -- <> foldMap (drawZoneCol green crZoneSize . zoneOfPoint crZoneSize) (xIntercepts crZoneSize a b) -- <> foldMap (drawZoneCol yellow crZoneSize . zoneOfPoint crZoneSize) (yIntercepts' crZoneSize a b) -- <> foldMap (drawLabCrossCol blue) (xIntercepts crZoneSize a b) +-- # OPTIONS -Wno-incomplete-uni-patterns #-} drawZoneCol :: Color -> Float -> V2 Int -> Picture drawZoneCol col s (V2 x y) = setLayer DebugLayer . color col $ thickLine 2 (p : ps ++ [p]) where @@ -337,7 +339,6 @@ drawWlIDs w = setLayer FixedCoordLayer $ foldMap f (w ^. cWorld . lWorld . walls where p = worldPosToScreen (w ^. wCam) $ 0.5 *.* uncurry (+.+) (_wlLine wl) - drawCrInfo :: Configuration -> World -> Picture drawCrInfo cfig w = setLayer FixedCoordLayer $ @@ -345,14 +346,14 @@ drawCrInfo cfig w = mapMaybe crDisplayInfo $ IM.elems $ w ^. cWorld . lWorld . creatures where cam = w ^. wCam --- drawPathing :: Configuration -> World -> Picture --- drawPathing cfig w = --- setLayer DebugLayer $ --- foldMap (edgeToPic (screenPolygon cfig (w ^. wCam)) . (^?! _3)) (FGL.labEdges gr) --- <> foldMap dispInc (graphToIncidence gr) --- where --- dispInc (p, n) = setDepth 2 . uncurryV translate p . scale 0.1 0.1 $ text $ show n --- gr = w ^. cWorld . pathGraph + -- drawPathing :: Configuration -> World -> Picture + -- drawPathing cfig w = + -- setLayer DebugLayer $ + -- foldMap (edgeToPic (screenPolygon cfig (w ^. wCam)) . (^?! _3)) (FGL.labEdges gr) + -- <> foldMap dispInc (graphToIncidence gr) + -- where + -- dispInc (p, n) = setDepth 2 . uncurryV translate p . scale 0.1 0.1 $ text $ show n + -- gr = w ^. cWorld . pathGraph crDisplayInfo :: Creature -> Maybe (Point2, [String]) crDisplayInfo cr @@ -396,4 +397,3 @@ edgeToPic poly pe where sp = _peStart pe ep = _peEnd pe - diff --git a/src/Dodge/HeldUse.hs b/src/Dodge/HeldUse.hs index bdeab0aec..7518fd3a8 100644 --- a/src/Dodge/HeldUse.hs +++ b/src/Dodge/HeldUse.hs @@ -1,3 +1,4 @@ +{-# OPTIONS -Wno-incomplete-uni-patterns #-} {-# LANGUAGE TupleSections #-} module Dodge.HeldUse ( @@ -5,8 +6,8 @@ module Dodge.HeldUse ( mcUseHeld, ) where -import Control.Monad import Color +import Control.Monad import Data.Maybe import Dodge.Base.Collide import Dodge.Base.Coordinate @@ -162,6 +163,7 @@ makeMuzzleFlare mz itmtree cr = case mz ^. mzFlareType of pos = _crPos cr + rotateV (_crDir cr) (_mzPos mz + aimingWeaponZeroPos cr itm) dir = _crDir cr + _mzRot mz +--{-# OPTIONS -Wno-incomplete-uni-patterns #-} muzFlareAt :: Color -> Point3 -> Float -> World -> World muzFlareAt col tranv dir w = w & randGen .~ g @@ -169,10 +171,10 @@ muzFlareAt col tranv dir w = where thepic = setLayer BloomNoZWrite . translate3 tranv . color col . rotate dir . polygon $ - [ V2 0 0 - , V2 a (- b) - , V2 c d - ] + [ V2 0 0 + , V2 a (- b) + , V2 c d + ] thestate = replicateM 4 $ state $ randomR (2, 20) (a : b : c : d : _, g) = runState thestate $ _randGen w -- randomRs (2, 20) (_randGen w) diff --git a/src/Dodge/Room/RezBox.hs b/src/Dodge/Room/RezBox.hs index b0acee5bd..59404c76d 100644 --- a/src/Dodge/Room/RezBox.hs +++ b/src/Dodge/Room/RezBox.hs @@ -1,5 +1,6 @@ module Dodge.Room.RezBox where +import Control.Monad import qualified Data.Set as S import Dodge.Cleat import Dodge.Data.GenWorld @@ -18,7 +19,6 @@ import Geometry import LensHelp import Padding import RandomHelp -import Control.Monad rezBox :: LightSource -> Room rezBox ls = @@ -51,8 +51,9 @@ rezBoxesWp = do let aroom = rezInvBox thecol -- & rmConnectsTo .~ S.singleton (OnEdge North) let isnorth = S.member (OnEdge North) . _rlType centralRoom <- - shuffleLinks $(roomRectAutoLinks w h){_rmPmnts = []} - & rmLinks %~ setLinkType InLink isnorth + shuffleLinks $ + (roomRectAutoLinks w h){_rmPmnts = []} + & rmLinks %~ setLinkType InLink isnorth onwardpassage <- shootOutPassage let n = length $ getLinksOfType (OnEdge North) $ _rmLinks centralRoom let rezrooms = @@ -117,10 +118,11 @@ rezBoxes = do shuffleLinks $ (roomRectAutoLinks w h){_rmPmnts = []} & rmLinks %~ setInLinks bottomEdgeTest - let n = length $ filter bottomEdgeTest $_rmLinks centralRoom - return $ - tToBTree "rezBoxes" $treeFromTrunk [rezBox thecol, door] $ - Node centralRoom (replicate (n -1) dbox ++ [Node (cleatOnward door) []]) + let n = length $ filter bottomEdgeTest $ _rmLinks centralRoom + return + . tToBTree "rezBoxes" + . treeFromTrunk [rezBox thecol, door] + $ Node centralRoom (replicate (n -1) dbox ++ [Node (cleatOnward door) []]) rezColor :: RandomGen g => State g LightSource rezColor = do diff --git a/src/Dodge/WdP2f.hs b/src/Dodge/WdP2f.hs index 14eb47e7a..43d9308a7 100644 --- a/src/Dodge/WdP2f.hs +++ b/src/Dodge/WdP2f.hs @@ -1,10 +1,14 @@ -module Dodge.WdP2f where +{-# OPTIONS -Wno-incomplete-uni-patterns #-} +module Dodge.WdP2f + ( doWdP2f + ) where import Control.Lens import Dodge.Data.World import Geometry.Data import Geometry.Vector +-- # OPTIONS -Wno-incomplete-uni-patterns #-} doWdP2f :: WdP2f -> World -> (Point2, Float) doWdP2f x = case x of WdP2f0 -> const (0, 0) diff --git a/src/Polyhedra.hs b/src/Polyhedra.hs index 8d7ecbd0f..ce1e2b542 100644 --- a/src/Polyhedra.hs +++ b/src/Polyhedra.hs @@ -1,3 +1,4 @@ +{-# OPTIONS -Wno-incomplete-uni-patterns #-} module Polyhedra ( translateXY , rotateXY diff --git a/src/Polyhedra/Geodesic.hs b/src/Polyhedra/Geodesic.hs index a1b6b66d6..7ce195e47 100644 --- a/src/Polyhedra/Geodesic.hs +++ b/src/Polyhedra/Geodesic.hs @@ -1,3 +1,4 @@ +{-# OPTIONS -Wno-incomplete-uni-patterns #-} {-# LANGUAGE TupleSections #-} module Polyhedra.Geodesic where diff --git a/src/RandomHelp.hs b/src/RandomHelp.hs index 8ad1542ef..2bcea9b51 100644 --- a/src/RandomHelp.hs +++ b/src/RandomHelp.hs @@ -1,3 +1,4 @@ +{-# OPTIONS -Wno-incomplete-uni-patterns #-} {- Helpers for random generation. -} module RandomHelp ( module System.Random, @@ -29,6 +30,7 @@ takeOneWeighted ws xs = state (randomR (0, sum ws)) >>= (\w -> return (xs !! i w | otherwise = 1 + i (y - z) zs i _ _ = 0 +--{-# OPTIONS -Wno-incomplete-uni-patterns #-} takeOneMore :: RandomGen g => ([a], [a]) -> State g ([a], [a]) takeOneMore (_, []) = error "trying to takeOneMore from empty list" takeOneMore (xs, ys) = do @@ -119,9 +121,3 @@ randsSpread (a, b) i randsOnCirc :: RandomGen g => Int -> State g [Float] randsOnCirc = randsSpread (0, 2 * pi) - ---randsOnCirc i --- | i <= 0 = error "tried to take <= 0 randsOnCirc" --- | otherwise = zipWith (+) [x,2*x..] <$> replicateM i (state $ randomR (0,x)) --- where --- x = 2*pi/fromIntegral i diff --git a/src/SimpleTrie.hs b/src/SimpleTrie.hs index 9bfab7f59..18a828da9 100644 --- a/src/SimpleTrie.hs +++ b/src/SimpleTrie.hs @@ -1,3 +1,4 @@ +{-# OPTIONS -Wno-incomplete-uni-patterns #-} {-# LANGUAGE TemplateHaskell #-} module SimpleTrie where @@ -29,6 +30,7 @@ lookupTrie :: Ord a => [a] -> Trie a b -> Maybe b lookupTrie (k : ks) t = _trieChildren t M.!? k >>= lookupTrie ks lookupTrie [] t = _trieMVal t +-- # OPTIONS -Wno-incomplete-uni-patterns #-} multiLookupTrie :: Ord a => [a] -> Trie a b -> [([a], b)] multiLookupTrie xs t@(Trie my ch) | null xs || null ch = maybe [] (\y -> [([], y)]) my diff --git a/src/Tile.hs b/src/Tile.hs index a450a637f..8122edc2b 100644 --- a/src/Tile.hs +++ b/src/Tile.hs @@ -1,39 +1,46 @@ -module Tile - ( tileTexCoords - , makeTileFromPoly - , baseFloorTileSize - ) - where +{-# OPTIONS -Wno-incomplete-uni-patterns #-} +module Tile ( + tileTexCoords, + makeTileFromPoly, + baseFloorTileSize, +) where + import Data.Tile import Geometry tileTexCoords :: Tile -> [Point2] -tileTexCoords t = map - (calcTexCoord (_tileZero t) tangent (- vNormal tangent)) - (_tilePoly t) +tileTexCoords t = + map + (calcTexCoord (_tileZero t) tangent (- vNormal tangent)) + (_tilePoly t) where tangent = _tileTangentPos t - _tileZero t -calcTexCoord - :: Point2 -- ^ tile (0,0) - -> Point2 -- ^ tile tangent - -> Point2 -- ^ tile cotangent - -> Point2 -- ^ world point - -> Point2 +calcTexCoord :: + -- | tile (0,0) + Point2 -> + -- | tile tangent + Point2 -> + -- | tile cotangent + Point2 -> + -- | world point + Point2 -> + Point2 calcTexCoord zp tangent cotangent p = V2 (f tangent) (f cotangent) where f t = closestPointOnLineParam zp (zp + t) p - +-- # OPTIONS -Wno-incomplete-uni-patterns #-} makeTileFromPoly :: [Point2] -> Float -> Tile -makeTileFromPoly poly z = Tile - { _tilePoly = poly - , _tileZero = c - , _tileTangentPos = c + (baseFloorTileSize *.* normalizeV (d -.- c)) - , _tileArrayZ = z - } +makeTileFromPoly poly z = + Tile + { _tilePoly = poly + , _tileZero = c + , _tileTangentPos = c + (baseFloorTileSize *.* normalizeV (d -.- c)) + , _tileArrayZ = z + } where - (c:d:_) = poly + (c : d : _) = poly baseFloorTileSize :: Float baseFloorTileSize = 50