diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,7 @@ +# History of ‘immutaball’ versions. + +## 0.1.0.5-dev + +## 0.1.0.4 -- 2025-04-10 + +- Released Immutaball with minimal functionality. diff --git a/Data/LabeledBinTree.hs b/Data/LabeledBinTree.hs new file mode 100644 --- /dev/null +++ b/Data/LabeledBinTree.hs @@ -0,0 +1,460 @@ +{-# OPTIONS_GHC -fno-warn-tabs #-} -- Support tab indentation better, for a better default of no warning if tabs are used: https://dmitryfrank.com/articles/indent_with_tabs_align_with_spaces . +-- Enable warnings: +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +-- CLI.hs. + +{-# LANGUAGE Haskell2010 #-} +{-# LANGUAGE TemplateHaskell, InstanceSigs #-} + +module Data.LabeledBinTree + ( + BinTree, + BinTreeF(..), + BinTreeLabeled, + LabeledBinTree(..), labeledBinTree, + Tree, + deconsLabeledBinTree, + mkLabeledEmpty, + mkLabeledLeaf, + mkLabeledFork, + fmapLabeledBinTree, + foldrLabeledBinTree, + simplifyLeavesLabeledBinTree, + simplifyEmptiesLabeledBinTree, + normalizeLabeledBinTree, + forkinizeLeaves, + forkinizeLeavesDirect, + joinLabeledBinTree, + joinDirectLabeledBinTree, + singletonLabeledBin, + repeatLabeledBinTree, + pureLabeledBinTreeLossy, + appLabeledBinTreeLossy, + labeledBinTreeConcatRightmost, + pureLabeledBinTreeCombinatorial, + appLabeledBinTreeCombinatorial, + mapLeavesDirectLabeledBinTree, + mapLeavesLabeledBinTree, + mapNonleavesLabeledBinTree, + bindLabeledBinTree, + traverseLBT, + + -- * Sizes + numElemsLBT, + numNodesWeightedDirectLBT, + numNodesDirectLBT, + numEmptyDirectLBT, + numLeavesDirectLBT, + numForkDirectLBT, + numAnyDirectLBT, + + numElemsLBTI, + numNodesWeightedDirectLBTI, + numNodesDirectLBTI, + numEmptyDirectLBTI, + numLeavesDirectLBTI, + numForkDirectLBTI, + numAnyDirectLBTI, + + -- * Constructor aliases + emptyLBT, + leafLBT, + forkLBT, + + -- * Equivalence relations + eqLBT, + leqLBT, + + -- * Utils + showFs, + showFs' + ) where + +import Prelude () +import Immutaball.Prelude + +import Data.Function hiding (id, (.)) + +import Control.Lens + +import Immutaball.Share.Utils + +type BinTree n l = Fixed (BinTreeF n l) +data BinTreeF n l me = + -- | Empty node. + EmptyBT + -- | Leaf node. + | LeafBT l + -- | Fork node. + | ForkBT me n me + deriving (Eq, Ord, Show) + +type BinTreeLabeled a = BinTree a a + +newtype LabeledBinTree a = LabeledBinTree {_labeledBinTree :: BinTreeLabeled a} + deriving (Eq, Ord, Show) +makeLenses ''LabeledBinTree + +type Tree = LabeledBinTree + +deconsLabeledBinTree :: r -> (a -> r) -> (LabeledBinTree a -> a -> LabeledBinTree a -> r) -> LabeledBinTree a -> r +deconsLabeledBinTree withEmptyBT _ _ (LabeledBinTree (Fixed (EmptyBT ))) = withEmptyBT +deconsLabeledBinTree _ withLeafBT _ (LabeledBinTree (Fixed (LeafBT a ))) = withLeafBT a +deconsLabeledBinTree _ _ withForkBT (LabeledBinTree (Fixed (ForkBT l a r))) = withForkBT (LabeledBinTree l) a (LabeledBinTree r) + +mkLabeledEmpty :: LabeledBinTree a +mkLabeledEmpty = LabeledBinTree . Fixed $ EmptyBT + +mkLabeledLeaf :: a -> LabeledBinTree a +mkLabeledLeaf a = LabeledBinTree . Fixed $ LeafBT a + +mkLabeledFork :: LabeledBinTree a -> a -> LabeledBinTree a -> LabeledBinTree a +mkLabeledFork l a r = LabeledBinTree . Fixed $ ForkBT (_labeledBinTree l) a (_labeledBinTree r) + +fmapLabeledBinTree :: (a -> b) -> (LabeledBinTree a -> LabeledBinTree b) +fmapLabeledBinTree f = deconsLabeledBinTree (mkLabeledEmpty) (\a -> mkLabeledLeaf (f a)) (\l a r -> mkLabeledFork (fmapLabeledBinTree f l) (f a) (fmapLabeledBinTree f r)) + +foldrLabeledBinTree :: (a -> b -> b) -> b -> LabeledBinTree a -> b +foldrLabeledBinTree f z = deconsLabeledBinTree + z + (\a -> f a z) + (\l a r -> foldrLabeledBinTree f (f a (foldrLabeledBinTree f z r)) l) + +-- | Replace all forks of empty nodes with leaf nodes. +-- +-- We can do this because 'LabeledBinTree' requires leaf and fork node +-- element types to be qual. +simplifyLeavesLabeledBinTree :: LabeledBinTree a -> LabeledBinTree a +simplifyLeavesLabeledBinTree = deconsLabeledBinTree + mkLabeledEmpty + (\a -> mkLabeledLeaf a) + (\l a r -> deconsLabeledBinTree + (deconsLabeledBinTree + (mkLabeledLeaf a) -- Replacement: both original left and right trees are empty. + (\_ra -> mkLabeledFork (simplifyLeavesLabeledBinTree l) a (simplifyLeavesLabeledBinTree r)) + (\_rl _ra _rr -> mkLabeledFork (simplifyLeavesLabeledBinTree l) a (simplifyLeavesLabeledBinTree r)) + r + ) + (\_la -> mkLabeledFork (simplifyLeavesLabeledBinTree l) a (simplifyLeavesLabeledBinTree r)) + (\_ll _la _lr -> mkLabeledFork (simplifyLeavesLabeledBinTree l) a (simplifyLeavesLabeledBinTree r)) + l + ) + +-- | Simplify a LabeledBinTree tree by removing all Leave constructs, replacing +-- leaves with forks of empties. The values of leaves is not lost; they are +-- simply reframed as forks of empties (with the value still present). +simplifyEmptiesLabeledBinTree :: LabeledBinTree a -> LabeledBinTree a +simplifyEmptiesLabeledBinTree = deconsLabeledBinTree + mkLabeledEmpty + (\a -> mkLabeledFork mkLabeledEmpty a mkLabeledEmpty) + (\l a r -> mkLabeledFork l a r ) + +--- | Normalize a LabeledBinTree with 'simplifyLeavesLabeledBinTree', +--- replacing all forks of empty nodes with leaf nodes. +normalizeLabeledBinTree :: LabeledBinTree a -> LabeledBinTree a +normalizeLabeledBinTree = simplifyLeavesLabeledBinTree + +-- | Replace all leaf nodes with a fork node with the given left and right +-- branches. +-- +-- Note: normalizing here doesn't change the result if we were to instead check +-- for leaf equivalence manually ourselves. +forkinizeLeaves :: LabeledBinTree a -> LabeledBinTree a -> LabeledBinTree a -> LabeledBinTree a +forkinizeLeaves ll base lr = forkinizeLeavesDirect ll (normalizeLabeledBinTree base) lr + +-- | Assuming the base tree is already normalized, replace all leaf nodes in +-- the base tree with a fork node with the given left and right branches. +forkinizeLeavesDirect :: LabeledBinTree a -> LabeledBinTree a -> LabeledBinTree a -> LabeledBinTree a +forkinizeLeavesDirect ll base lr = deconsLabeledBinTree + mkLabeledEmpty + (\a -> mkLabeledFork ll a lr) + (\l a r -> mkLabeledFork (forkinizeLeavesDirect ll l lr) a (forkinizeLeavesDirect ll r lr)) + base + +-- | Replace each of the root tree's inner leaf nodes with a fork node whose +-- left branch is the likewise joined outer left tree and whose right branch is +-- the likewise joined outer right tree. This is perhaps like a +-- non-determinism of paths to leaves, perhaps somewhat like list monad +-- non-determinism. +joinLabeledBinTree :: LabeledBinTree (LabeledBinTree a) -> LabeledBinTree a +joinLabeledBinTree = joinDirectLabeledBinTree . normalizeLabeledBinTree . (normalizeLabeledBinTree <$>) + +-- | 'joinLabeledBinTree' that assumes the tree and all nested trees have +-- already been normalized. +joinDirectLabeledBinTree :: LabeledBinTree (LabeledBinTree a) -> LabeledBinTree a +joinDirectLabeledBinTree = deconsLabeledBinTree + mkLabeledEmpty + (\a -> a) + (\l a r -> forkinizeLeavesDirect (joinDirectLabeledBinTree l) a (joinDirectLabeledBinTree r)) + +singletonLabeledBin :: a -> LabeledBinTree a +singletonLabeledBin x = mkLabeledLeaf x + +repeatLabeledBinTree :: a -> LabeledBinTree a +repeatLabeledBinTree x = mkLabeledFork (repeatLabeledBinTree x) x (repeatLabeledBinTree x) + +pureLabeledBinTreeLossy :: a -> LabeledBinTree a +pureLabeledBinTreeLossy x = repeatLabeledBinTree x + +-- | Zip-like lossy Applicative for LabeledBinTree: component-wise. +appLabeledBinTreeLossy :: (LabeledBinTree (a -> b)) -> LabeledBinTree a -> LabeledBinTree b +appLabeledBinTreeLossy mf ma = deconsLabeledBinTree + (mkLabeledEmpty) -- Discard any remaining elements of ‘ma’. + (\f -> + deconsLabeledBinTree + (mkLabeledEmpty) -- Discard the remaining elements of ‘mf’. + (\a -> mkLabeledLeaf (f a)) + (\_ a _ -> mkLabeledLeaf (f a)) -- Discard the remaining elements of ‘ma’. + ma + ) + (\fl f fr -> + deconsLabeledBinTree + (mkLabeledEmpty) -- Discard the remaining elements of ‘mf’. + (\a -> mkLabeledLeaf (f a)) -- Discard the remaining elements of ‘mf’. + (\al a ar -> mkLabeledFork + (appLabeledBinTreeLossy fl al) + (f a) + (appLabeledBinTreeLossy fr ar) + ) + ma + ) + mf + +-- | Add another tree to the right-most leaf of this tree. +-- +-- Keep following the right-most node until empty is found, and then replace it +-- with the sub-tree. +labeledBinTreeConcatRightmost :: LabeledBinTree a -> LabeledBinTree a -> LabeledBinTree a +labeledBinTreeConcatRightmost base additional = deconsLabeledBinTree + additional + (\a -> mkLabeledFork mkLabeledEmpty a additional) + (\l a r -> mkLabeledFork l a (labeledBinTreeConcatRightmost r additional)) + base + +pureLabeledBinTreeCombinatorial :: a -> LabeledBinTree a +pureLabeledBinTreeCombinatorial x = mkLabeledLeaf x + +-- | List-like combinatorial Applicative for LabeledBinTree, with a focus on +-- leaves. +-- +-- Note: since ‘m >>= f = join (f <$> m)’ +-- and ‘m1 <*> m2 = m1 >>= (\x1 -> m2 >>= (\x2 -> return (x1 x2)))’, +-- then applying a binary tree of integer unaops (e.g. plus 1, times 2, squared +-- plus 3, etc.) to a binary tree of integers, would mean ‘m1 <*> m2’ is: +-- map, for each binop: map, for each integer: singleton of the binop applied +-- to the integer; then join; then join. Before the first join, we have a +-- binary tree of a binary tree of a binary tree: a binary tree of, for each of +-- the unaops, a binary tree of the integers, except the integers are singleton +-- applications of the function to the integer. Joining a binary tree of +-- singletons returns the same binary tree without the singleton wrappers (join +-- composed with pure), so after the first, inner join, we then have: a binary +-- tree of, for each of the unaops, a binary tree of the original integers each +-- applied to that unaop. (e.g. copy the integer tree for each node in the +-- unaop tree, and apply that unop.) We now have a binary tree of binary +-- trees, where each node in the outer tree represents which unary operation / +-- function we applied to the inner list to get the inner tree output for that +-- unaop. +-- +-- Finally, given this binary tree of outputs for each unaop, we perform +-- another join: take the root binary tree, representing, say, the mapping of +-- the ‘plus1’ root unaop to the input integers, and then for each leaf, turn +-- it into a fork node where the left gets you a continued pattern for the +-- root's left unaops tree, and likewise for right. +-- +-- So the result is you start with the root node function applied to the +-- argument tree, but once you reach any leaf, you can keep descending either +-- left or right (possibly a branch can be Empty), and repeat the original +-- argument/input tree except for different unaops. e.g. go to a leaf for the +-- root unaop, then go left, go to a would-be leaf, then go left again, and +-- then you start the tree for the unaop at the unaop tree's root's left's left +-- node's function. +appLabeledBinTreeCombinatorial :: LabeledBinTree (a -> b) -> LabeledBinTree a -> LabeledBinTree b +appLabeledBinTreeCombinatorial mf ma = joinLabeledBinTree ((\f -> (\a -> f a) <$> ma) <$> mf) + +-- | Map leaf nodes, only checking directly for leaves. Normalizing the tree +-- can yield different results. To also map nodes that would be leaves when +-- normalized, use 'mapLeavesLabeledBinTree'. +mapLeavesDirectLabeledBinTree :: (a -> a) -> LabeledBinTree a -> LabeledBinTree a +mapLeavesDirectLabeledBinTree f = deconsLabeledBinTree + mkLabeledEmpty + (\a -> mkLabeledLeaf (f a)) + (\l a r -> mkLabeledFork (mapLeavesDirectLabeledBinTree f l) a (mapLeavesDirectLabeledBinTree f r)) + +-- | 'mapLeavesDirectLabeledBinTree' but treats forks of empty nodes as leaves. +mapLeavesLabeledBinTree :: (a -> a) -> LabeledBinTree a -> LabeledBinTree a +mapLeavesLabeledBinTree f = deconsLabeledBinTree + mkLabeledEmpty + (\a -> mkLabeledLeaf (f a)) + --(\l a r -> mkLabeledFork (mapLeavesDirectLabeledBinTree l) a (mapLeavesDirectLabeledBinTree r)) + (\l a r -> deconsLabeledBinTree + (deconsLabeledBinTree + ( mkLabeledFork (mapLeavesDirectLabeledBinTree f l) (f a) (mapLeavesDirectLabeledBinTree f r)) + (\_ra -> mkLabeledFork (mapLeavesDirectLabeledBinTree f l) a (mapLeavesDirectLabeledBinTree f r)) + (\_rl _ra _rr -> mkLabeledFork (mapLeavesDirectLabeledBinTree f l) a (mapLeavesDirectLabeledBinTree f r)) + r + ) + (\_la -> mkLabeledFork (mapLeavesDirectLabeledBinTree f l) a (mapLeavesDirectLabeledBinTree f r)) + (\_ll _la _lr -> mkLabeledFork (mapLeavesDirectLabeledBinTree f l) a (mapLeavesDirectLabeledBinTree f r)) + l + ) + +-- | Map each element, skipping leaves. +mapNonleavesLabeledBinTree :: (a -> a) -> LabeledBinTree a -> LabeledBinTree a +mapNonleavesLabeledBinTree f = deconsLabeledBinTree + mkLabeledEmpty + mkLabeledLeaf + (\l a r -> mkLabeledFork (mapNonleavesLabeledBinTree f l) (f a) (mapNonleavesLabeledBinTree f r)) + +-- | For each element in the (left) tree, replace with the tree produced by +-- applying the function to that element, where each leaf becomes a fork node +-- with its left and right children having likewise binding. +-- +-- See 'joinLabeledBinTree' for more information. +bindLabeledBinTree :: LabeledBinTree a -> (a -> LabeledBinTree b) -> LabeledBinTree b +bindLabeledBinTree ma f = joinLabeledBinTree (f <$> ma) + +instance Functor LabeledBinTree where + fmap :: (a -> b) -> (LabeledBinTree a -> LabeledBinTree b) + fmap = fmapLabeledBinTree + +instance Foldable LabeledBinTree where + foldr :: (a -> b -> b) -> b -> LabeledBinTree a -> b + foldr = foldrLabeledBinTree + +-- | The default Applicative instance of LabeledBinTree is 'appLabeledBinTreeCombinatorial'. +instance Applicative LabeledBinTree where + pure :: a -> LabeledBinTree a + pure = pureLabeledBinTreeCombinatorial + (<*>) :: LabeledBinTree (a -> b) -> LabeledBinTree a -> LabeledBinTree b + (<*>) = appLabeledBinTreeCombinatorial + +-- | The default Monad instance of LabeledBinTree uses 'joinLabeledBinTree' +-- +-- If my hand-wavy analysis is correct, joining trees strictly would have +-- exponentially growing space costs, so it may rarely be useful to use this +-- if evaluating the entire tree, rather than only down a specific or select +-- set of paths through the tree. +instance Monad LabeledBinTree where + return :: a -> LabeledBinTree a + return = pure + (>>=) :: LabeledBinTree a -> (a -> LabeledBinTree b) -> LabeledBinTree b + (>>=) = bindLabeledBinTree + +traverseLBT :: Applicative f => (a -> f b) -> LabeledBinTree a -> f (LabeledBinTree b) +traverseLBT f = deconsLabeledBinTree + ( pure emptyLBT) + (\a -> pure leafLBT <*> f a) + (\l a r -> pure forkLBT <*> traverseLBT f l <*> f a <*> traverseLBT f r) + +instance Traversable LabeledBinTree where + traverse :: Applicative f => (a -> f b) -> LabeledBinTree a -> f (LabeledBinTree b) + traverse = traverseLBT + +-- * Sizes + +-- | The number of non-empty elements in an lbt. +numElemsLBT :: (Num i) => LabeledBinTree a -> i +numElemsLBT = foldr (\_x acc -> acc + 1) 0 + +-- | The number of nodes, empty, leaf, or forking. +-- +-- Provide the size of empty, leaf, and forking nodes (e.g. 0, 1, 1) and find +-- the sum. +numNodesWeightedDirectLBT :: (Num i) => i -> i -> i -> LabeledBinTree a -> i +numNodesWeightedDirectLBT a b c tree0 = (\f -> f 0 [tree0]) . fix $ \count counter remaining -> case remaining of + [] -> counter + (tree:remaining') -> deconsLabeledBinTree + ( count (counter + a) $ remaining') + (\_a -> count (counter + b) $ remaining') + (\l _a r -> count (counter + c) $ l:r:remaining') + tree + +-- | The number of nodes, empty, leaf, or forking. +numNodesDirectLBT :: (Num i) => LabeledBinTree a -> i +numNodesDirectLBT = numNodesWeightedDirectLBT 1 1 1 + +-- | Count the number of empty nodes. +numEmptyDirectLBT :: (Num i) => LabeledBinTree a -> i +numEmptyDirectLBT = numNodesWeightedDirectLBT 1 0 0 + +-- | Count the number of leaf nodes. +numLeavesDirectLBT :: (Num i) => LabeledBinTree a -> i +numLeavesDirectLBT = numNodesWeightedDirectLBT 0 1 0 + +-- | Count the number of fork nodes (branching). +numForkDirectLBT :: (Num i) => LabeledBinTree a -> i +numForkDirectLBT = numNodesWeightedDirectLBT 0 0 1 + +-- | Count the number of nodes in the tree of any of the 3 kinds. +numAnyDirectLBT :: (Num i) => LabeledBinTree a -> i +numAnyDirectLBT = numNodesWeightedDirectLBT 1 1 1 + +-- | 'numElemsLBT' specialized to Integer. +numElemsLBTI :: LabeledBinTree a -> Integer +numElemsLBTI = numElemsLBT + +-- | 'numNodesWeightedDirectLBT' specialized to Integer. +numNodesWeightedDirectLBTI :: Integer -> Integer -> Integer -> LabeledBinTree a -> Integer +numNodesWeightedDirectLBTI = numNodesWeightedDirectLBT + +-- | 'numNodesDirectLBT' specialized to Integer. +numNodesDirectLBTI :: LabeledBinTree a -> Integer +numNodesDirectLBTI = numNodesDirectLBT + +-- | 'numEmptyDirectLBT' specialized to Integer. +numEmptyDirectLBTI :: LabeledBinTree a -> Integer +numEmptyDirectLBTI = numEmptyDirectLBT + +-- | 'numLeavesDirectLBT' specialized to Integer. +numLeavesDirectLBTI :: LabeledBinTree a -> Integer +numLeavesDirectLBTI = numLeavesDirectLBT + +-- | 'numForkDirectLBT' specialized to Integer. +numForkDirectLBTI :: LabeledBinTree a -> Integer +numForkDirectLBTI = numForkDirectLBT + +-- | 'numAnyDirectLBT' specialized to Integer. +numAnyDirectLBTI :: LabeledBinTree a -> Integer +numAnyDirectLBTI = numAnyDirectLBT + +-- * Constructor aliases + +-- | Shorter alias of 'mkLabeledEmpty'. +emptyLBT :: LabeledBinTree a +emptyLBT = mkLabeledEmpty + +-- | Shorter alias of 'mkLabeledLeaf'. +leafLBT :: a -> LabeledBinTree a +leafLBT = mkLabeledLeaf + +-- | Shorter alias of 'mkLabeledFork'. +forkLBT :: LabeledBinTree a -> a -> LabeledBinTree a -> LabeledBinTree a +forkLBT = mkLabeledFork + +-- * Equivalence relations + +-- | Equivalence after normalization. +eqLBT :: (Eq a) => LabeledBinTree a -> LabeledBinTree a -> Bool +eqLBT = (==) `on` normalizeLabeledBinTree + +-- | Leq after normalization. +leqLBT :: (Ord a) => LabeledBinTree a -> LabeledBinTree a -> Bool +leqLBT = (<=) `on` normalizeLabeledBinTree + +-- | fs-style show. +showFs :: (Show a) => LabeledBinTree a -> String +showFs = showFs' show + +-- | fs-style show, with a custom Show instance of ‘a’; primitive but still +-- more readable than default Show. +-- +-- This implementation is currently relatively inefficient, since there is a +-- lot of unneeded repeated concatenation. Consider DLists if wanting to +-- improve. +showFs' :: (a -> String) -> LabeledBinTree a -> String +showFs' showA tree = (\f -> f "" tree) . fix $ \withPrefix prefix subtree -> deconsLabeledBinTree + (prefix ++ "×\n") + (\a -> prefix ++ (showA a) ++ "\n") + (\l a r -> prefix ++ showA a ++ "\n" ++ withPrefix (prefix ++ "\t.") l ++ withPrefix (prefix ++ "\t·") r) + subtree diff --git a/Immutaball/Ball/CLI.hs b/Immutaball/Ball/CLI.hs --- a/Immutaball/Ball/CLI.hs +++ b/Immutaball/Ball/CLI.hs @@ -17,6 +17,8 @@ immutaballOptions, immutaballWithArgs, immutaballHelp, + immutaballHelp', + immutaballIntroText, immutaballVersion, immutaballWithCLIConfig, cliIBDirs, @@ -40,6 +42,7 @@ -- external imports import Control.Lens +import Control.Wire.Meta (isFallbackWire) import qualified Data.Text as T import System.FilePath @@ -106,6 +109,21 @@ Option [] ["headless"] (NoArg . b $ cliCfgHeadless .~ True) "", Option [] ["no-headless"] (NoArg . b $ cliCfgHeadless .~ False) + "", + + Option ['Q'] ["skip-intro-text"] (NoArg . b $ cliCfgSkipIntroText .~ True) + "", + Option [] ["no-skip-intro-text"] (NoArg . b $ cliCfgSkipIntroText .~ False) + "", + + Option [] ["help-detailed"] (NoArg . b $ cliCfgHelpDetailed .~ True) + "", + Option [] ["no-help-detailed"] (NoArg . b $ cliCfgHelpDetailed .~ False) + "", + + Option [] ["request-override-physics"] (ReqArg (\str -> b $ cliCfgOverridePhysics .~ Just (Just str)) "") + "", + Option [] ["no-request-override-physics"] (NoArg . b $ cliCfgOverridePhysics .~ Nothing) "" ] where b = CLIConfigBuilder @@ -129,7 +147,10 @@ | otherwise = immutaballWithCLIConfig x'cfg cliCfg immutaballHelp :: String -immutaballHelp = intercalate "\n" $ +immutaballHelp = immutaballHelp' False + +immutaballHelp' :: Bool -> String +immutaballHelp' detailed = intercalate "\n" $ [ "Usage: immutaball [options…]", "", @@ -143,11 +164,76 @@ "\t--user-config-dir PATH:", "\t\tSet user config directory path.", "\t--headless:", - "\t\tDisable video and audio. Useful for automated testing." + "\t\tDisable video and audio. Useful for automated testing.", + "\t-Q, --skip-intro-text:", + "\t\tSilence the intro text on startup.", + "\t--help-detailed:", + "\t\tShow additional usage and exit." + ] ++ if' (not detailed) [] + [ + "", + "Additional options:", + "\t--request-override-physics=default:", + "\t\tFor debugging or development, select the default physics algorithm.", + "\t--request-override-physics=stationary:", + "\t\tFor debugging or development, select the stationary physics algorithm.", + "\t--request-override-physics=ghostly:", + "\t\tFor debugging or development, select the ghostly physics algorithm.", + "\t--request-override-physics=brute-force:", + "\t\tFor debugging or development, select the brute-force physics algorithm.", + "\t\tWARNING: does not perform well on large levels and may freeze!", + "\t--request-override-physics=bsp:", + "\t\tFor debugging or development, select the bsp physics algorithm." ] +immutaballIntroText :: String +immutaballIntroText = intercalate "\n" $ + [ + "Welcome to Immutaball v" ++ immutaballVersion ++ "!", + "", + "WARNING: This prototype version currently only implements", + " basic functionality; much of the game is yet unimplemented.", + " A basic GUI, renderer, and physics is currently supported.", + " Currently, the physics does not fully support moving bodies,", + " and currently seems to have a few bugs.", + "", + "To use Immutaball, you'll need to build Neverball and call Immutaball", + "with the path to the data dir in the Neverball build:", + "\tcd ~/git", + "\tgit clone https://github.com/Neverball/neverball", + "\tcd ~/git/neverball", + "\t# git checkout 1.7.0-alpha.3 # Optionally check out the most recent version known to be supported if there are issues.", + "\tmake -j7", + "", + "\tcd ~/git", + "\tgit clone https://github.com/nibzdil/immutaball", + "\tcd ~/git/immutaball", + "\tcabal build --enable-tests", + "\tcabal run immutaball -- -d ~/git/neverball/data", + "", + "Alternatively, if there is a system-installed Neverball package", + "already built, you can also use its data path instead when passing", + "‘-d PATH’.", + "" + ] ++ + (if' (not isFallbackWire) + [ + "Using external dependency ‘wires’ (not fallback implementation)." + ] + [ + "Not using external package ‘wires’ for dependency", + "(perhaps it failed to build); using fallback implementation", + "(performance not necessarily optimized)." + ] + ) ++ + [ + "", + "Pass ‘--help’ for usage information.", + "Pass ‘-Q’ to silence this intro text." + ] + immutaballVersion :: String -immutaballVersion = "0.1.0.4.1-hackage" +immutaballVersion = "0.1.0.5.1-hackage" -- | Run immutaball. immutaballWithCLIConfig :: StaticConfig -> CLIConfig -> ImmutaballIO @@ -156,13 +242,27 @@ where showHelp :: ImmutaballIO showHelp = mkBIO . PutStrLn immutaballHelp $ mkBIO ExitSuccessBasicIOF + showHelp' :: Bool -> ImmutaballIO + showHelp' detailed = mkBIO . PutStrLn (immutaballHelp' detailed) $ mkBIO ExitSuccessBasicIOF showVersion :: ImmutaballIO showVersion = mkBIO . PutStrLn immutaballVersion $ mkBIO ExitSuccessBasicIOF + showIntroTextThen :: ImmutaballIO -> ImmutaballIO + showIntroTextThen + | null immutaballIntroText = id + | (cliCfg^.cliCfgSkipIntroText) = id + | otherwise = + mkBIO . PutStrLn immutaballIntroText + -- Allow CLI options to update the static config. + x'cfg' :: StaticConfig + x'cfg' + | Just val <- cliCfg^.cliCfgOverridePhysics = x'cfg & x'cfgRequestAlternativePhysics .~ val + | otherwise = x'cfg result :: ImmutaballIO result - | cliCfg^.cliCfgHelp = showHelp - | cliCfg^.cliCfgVersion = showVersion - | otherwise = immutaballWithCLIConfig' x'cfg cliCfg + | cliCfg^.cliCfgHelpDetailed = showHelp' True + | cliCfg^.cliCfgHelp = showHelp + | cliCfg^.cliCfgVersion = showVersion + | otherwise = showIntroTextThen $ immutaballWithCLIConfig' x'cfg' cliCfg cliIBDirs :: CLIConfig -> IBDirs -> IBDirs cliIBDirs cliCfg defaultIBDirs = IBDirs { diff --git a/Immutaball/Ball/CLI/Config.hs b/Immutaball/Ball/CLI/Config.hs --- a/Immutaball/Ball/CLI/Config.hs +++ b/Immutaball/Ball/CLI/Config.hs @@ -11,6 +11,7 @@ ( CLIConfig(..), cliCfgHelp, cliCfgVersion, cliCfgStaticDataDir, cliCfgUserDataDir, cliCfgUserConfigDir, cliCfgHeadless, + cliCfgSkipIntroText, cliCfgHelpDetailed, cliCfgOverridePhysics, defaultCLIConfig, CLIConfigBuilder(..), modifyCLIConfig, buildCLIConfig @@ -22,24 +23,30 @@ import Control.Lens data CLIConfig = CLIConfig { - _cliCfgHelp :: Bool, - _cliCfgVersion :: Bool, - _cliCfgStaticDataDir :: Maybe FilePath, - _cliCfgUserDataDir :: Maybe FilePath, - _cliCfgUserConfigDir :: Maybe FilePath, - _cliCfgHeadless :: Bool + _cliCfgHelp :: Bool, + _cliCfgVersion :: Bool, + _cliCfgStaticDataDir :: Maybe FilePath, + _cliCfgUserDataDir :: Maybe FilePath, + _cliCfgUserConfigDir :: Maybe FilePath, + _cliCfgHeadless :: Bool, + _cliCfgSkipIntroText :: Bool, + _cliCfgHelpDetailed :: Bool, + _cliCfgOverridePhysics :: Maybe (Maybe String) } deriving (Eq, Ord) makeLenses ''CLIConfig defaultCLIConfig :: CLIConfig defaultCLIConfig = CLIConfig { - _cliCfgHelp = False, - _cliCfgVersion = False, - _cliCfgStaticDataDir = Nothing, - _cliCfgUserDataDir = Nothing, - _cliCfgUserConfigDir = Nothing, - _cliCfgHeadless = False + _cliCfgHelp = False, + _cliCfgVersion = False, + _cliCfgStaticDataDir = Nothing, + _cliCfgUserDataDir = Nothing, + _cliCfgUserConfigDir = Nothing, + _cliCfgHeadless = False, + _cliCfgSkipIntroText = False, + _cliCfgHelpDetailed = False, + _cliCfgOverridePhysics = Nothing } newtype CLIConfigBuilder = CLIConfigBuilder {_modifyCLIConfig :: CLIConfig -> CLIConfig} diff --git a/Immutaball/Ball/Game.hs b/Immutaball/Ball/Game.hs --- a/Immutaball/Ball/Game.hs +++ b/Immutaball/Ball/Game.hs @@ -297,6 +297,7 @@ initialGameState cxt neverballrc hasLevelBeenCompleted mlevelSet solPath sol = fix $ \gs -> let solAnalysis = mkSolAnalysis cxt (gs^.gsSol) in par (M.size $ solAnalysis^.saPhysicsAnalysis.spaLumpPlanes) . + par (solAnalysis^.saPhysicsAnalysis.spaBSPNumPartitions) . par solAnalysis $ GameState { _gsGameMode = Intermission, diff --git a/Immutaball/Ball/Level.hs b/Immutaball/Ball/Level.hs new file mode 100644 --- /dev/null +++ b/Immutaball/Ball/Level.hs @@ -0,0 +1,17 @@ +{-# OPTIONS_GHC -fno-warn-tabs #-} -- Support tab indentation better, for a better default of no warning if tabs are used: https://dmitryfrank.com/articles/indent_with_tabs_align_with_spaces . +-- Enable warnings: +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +-- Level.hs. + +{-# LANGUAGE Haskell2010 #-} + +module Immutaball.Ball.Level + ( + module Immutaball.Ball.Level.Render + ) where + +import Prelude () +--import Immutaball.Prelude + +import Immutaball.Ball.Level.Render diff --git a/Immutaball/Ball/Level/Render.hs b/Immutaball/Ball/Level/Render.hs new file mode 100644 --- /dev/null +++ b/Immutaball/Ball/Level/Render.hs @@ -0,0 +1,265 @@ +{-# OPTIONS_GHC -fno-warn-tabs #-} -- Support tab indentation better, for a better default of no warning if tabs are used: https://dmitryfrank.com/articles/indent_with_tabs_align_with_spaces . +-- Enable warnings: +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +-- Level/Render.hs. + +{-# LANGUAGE Haskell2010 #-} +{-# LANGUAGE Arrows, ScopedTypeVariables #-} + +-- | Level rendering. +module Immutaball.Ball.Level.Render + ( + renderLevel, + renderSetupNewLevel, + renderScene, + renderGeomPass + ) where + +import Prelude () +import Immutaball.Prelude + +import Control.Arrow +import Control.Monad +import Data.Int +import Data.Ix +import Data.Maybe + +import Control.Lens +import Data.Array.IArray +import qualified Data.Map.Lazy as M +import Graphics.GL.Compatibility45 +--import Graphics.GL.Core45 +import Graphics.GL.Types + +import Immutaball.Ball.Game +import Immutaball.Ball.State.Game -- rendererTransformationMatrix, getPathTranslation +import Immutaball.Share.Config +import Immutaball.Share.Context +import Immutaball.Share.ImmutaballIO.GLIO +import Immutaball.Share.Level.Analysis +import Immutaball.Share.Level.Base +import Immutaball.Share.Math +import Immutaball.Share.SDLManager +import Immutaball.Share.State +import Immutaball.Share.State.Context +import Immutaball.Share.Utils +import Immutaball.Share.Video +import Immutaball.Share.Wire + +renderLevel :: Wire ImmutaballM ((MView, SolWithAnalysis, GameState), IBStateContext) IBStateContext +renderLevel = proc ((camera_, swa, gs), cxtn) -> do + -- Set up. + let levelPath = swa^.swaMeta.smPath + (mlastLevelPath, cxtnp1) <- setCurrentlyLoadedSOL -< (levelPath, cxtn) + let newLevel = not $ Just levelPath == mlastLevelPath + cxtnp2 <- returnA ||| renderSetupNewLevel -< if' (not newLevel) (Left cxtnp1) (Right (swa, cxtnp1)) + + -- Render the scene. + cxtnp3 <- renderScene -< ((camera_, swa, gs), cxtnp2) + + -- Return the state context. + + let cxt = cxtnp3 + returnA -< cxt + +renderSetupNewLevel :: Wire ImmutaballM (SolWithAnalysis, IBStateContext) IBStateContext +renderSetupNewLevel = proc (swa, cxtn) -> do + let sra = swa^.swaSa.saRenderAnalysis + + -- Upload SSBOs. + cxtnp1 <- setSSBO -< ((shaderSSBOVertexDataLocation, sra^.sraVertexDataGPU), cxtn) + cxtnp2 <- setSSBO -< ((shaderSSBOGeomDataLocation, sra^.sraGeomDataGPU), cxtnp1) + cxtnp3 <- setSSBO -< ((shaderSSBOLumpDataLocation, sra^.sraLumpDataGPU), cxtnp2) + cxtnp4 <- setSSBO -< ((shaderSSBOPathDoublesDataLocation, sra^.sraPathDoublesDataGPU), cxtnp3) + cxtnp5 <- setSSBO -< ((shaderSSBOPathInt32sDataLocation, sra^.sraPathInt32sDataGPU), cxtnp4) + cxtnp6 <- setSSBO -< ((shaderSSBOBodyDataLocation, sra^.sraBodyDataGPU), cxtnp5) + cxtnp7 <- setSSBO -< ((shaderSSBOGcDataLocation, sra^.sraGcArrayGPU), cxtnp6) + cxtnp8 <- setSSBO -< ((shaderSSBOAllGeomPassMvDataLocation, sra^.sraAllGeomPassMvGPU), cxtnp7) + cxtnp9 <- setSSBO -< ((shaderSSBOAllGeomPassTexturesDataLocation, sra^.sraAllGeomPassTexturesGPU), cxtnp8) + cxtnp10 <- setSSBO -< ((shaderSSBOAllGeomPassGisDataLocation, sra^.sraAllGeomPassGisGPU), cxtnp9) + cxtnp11 <- setSSBO -< ((shaderSSBOGeomPassMvRangesDataLocation, sra^.sraGeomPassMvRangesGPU), cxtnp10) + cxtnp12 <- setSSBO -< ((shaderSSBOGeomPassTexturesRangesDataLocation, sra^.sraGeomPassTexturesRangesGPU), cxtnp11) + cxtnp13 <- setSSBO -< ((shaderSSBOGeomPassGisRangesDataLocation, sra^.sraGeomPassGisRangesGPU), cxtnp12) + cxtnp14 <- setSSBO -< ((shaderSSBOGeomPassBisDataLocation, sra^.sraGeomPassBisGPU), cxtnp13) + cxtnp15 <- setSSBO -< ((shaderSSBOTexcoordsDoubleDataLocation, sra^.sraTexcoordsDoubleDataGPU), cxtnp14) + + -- Upload elems vao and buf. + cxtnp16 <- setElemVaoVboEbo -< (sra^.sraGcArrayGPU, True, cxtnp15) + + -- Pre-initialize the transformation matrix with the identity. + cxtnp17 <- setTransformation -< (identity4, cxtnp16) + + -- Approximate disabling OpenGL clipping by depth (by our transformed y coordinates, which transform into OpenGL z depth coordinates). + -- Also other miscellaneous OpenGL setup. + let sdlGL1'_ = sdlGL1 (cxtnp17^.ibContext.ibSDLManagerHandle) + let sdlGL1' = liftIBIO . sdlGL1'_ + () <- monadic -< sdlGL1' $ do + -- TODO FIXME: this doesn't seem to actually stop clipping for depth + -- values outside a certain range. + -- + -- To investigate, disable rescaleDepth, try retour de force level 2, + -- enable free camera, and rotate the camera until you can see the + -- level. Move toward that location, and then you can see that the + -- distance from the camera needs to be only within a certain range. + -- + -- So instead we'll just use rescaleDepth. + GLDepthRange (cxtnp17^.ibContext.ibStaticConfig.x'glNearVal) (cxtnp17^.ibContext.ibStaticConfig.x'glFarVal) () + -- Other miscellaneous OpenGL setup. + () <- monadic -< sdlGL1' $ do + --GLPlaceholder GL_VAL () + pure () + + -- Return the state context. + + let cxt = cxtnp17 + + returnA -< cxt + +-- | After setup, render the scene. +renderScene :: Wire ImmutaballM ((MView, SolWithAnalysis, GameState), IBStateContext) IBStateContext +renderScene = proc ((camera_, swa, gs), cxtn) -> do + -- Set up the transformation matrix. + --let mat = rendererTransformationMatrix camera_ + mat <- arr $ uncurry3 rendererTransformationMatrix -< (cxtn, gs, camera_) + cxtnp1 <- setTransformation -< (mat, cxtn) + + -- Render the scene. + let + sol :: Sol + sol = swa^.swaSol + + sa :: SolAnalysis + sa = swa^.swaSa + + sra :: SolRenderAnalysis + sra = sa^.saRenderAnalysis + let _unused = (sol) + + let + ourFlatten :: (Int32, (MView, SolWithAnalysis, GameState, Bool, GeomPass)) -> (Int32, MView, SolWithAnalysis, GameState, Bool, GeomPass) + ourFlatten (a, (b, c, d, e, f)) = (a, b, c, d, e, f) + let geomPasses = map ourFlatten . zip [0..] $ map (\gp -> (camera_, swa, gs, False, gp)) (sra^.sraOpaqueGeoms) ++ map (\gp -> (camera_, swa, gs, True, gp)) (sra^.sraTransparentGeoms) + cxtnp2 <- foldlA renderGeomPass -< (cxtnp1, geomPasses) + + -- Return the state context. + let cxt = cxtnp2 + + returnA -< cxt + +-- | Render a partition of the level geometry, so that we can handle processing up to 16 textures at a time. +renderGeomPass :: Wire ImmutaballM (IBStateContext, (Int32, MView, SolWithAnalysis, GameState, Bool, GeomPass)) IBStateContext +renderGeomPass = proc (cxtn, (geomPassIdx, camera_, swa, gs, isAlpha, gp)) -> do + -- Setup. + let sdlGL1'_ = sdlGL1 (cxtn^.ibContext.ibSDLManagerHandle) + let sdlGL1' = liftIBIO . sdlGL1'_ + + -- Render the geom pass. + + -- First, if the body is on a path, update the transformation matrix to + -- reflect the translation on the path. TODO: currently we only support + -- translations on paths here. + let bi = gp^.gpBi + let body = (swa^.swaSol.solBv) ! bi + let (moriginPath :: Maybe Int32) = do + let originPath = body^.bodyP0 + guard . inRange (bounds $ swa^.swaSol.solPv) $ originPath + return $ originPath + let (mpathTransformation :: Maybe (Mat4 Double)) = do + originNode <- moriginPath + let bodyTranslation = getPathTranslation (swa^.swaSol) (swa^.swaSa.saOtherAnalysis) gs originNode 0 + let transformation = translate3 bodyTranslation + return transformation + mat <- arr $ uncurry3 rendererTransformationMatrix -< (cxtn, gs, camera_) + let (mnetBodyTransformation :: Maybe (Mat4 Double)) = do + pathTransformation <- mpathTransformation + return $ mat <> pathTransformation + cxtnp1 <- returnA ||| setTransformation -< deconsMaybe (Left cxtn) (\pathTransformation -> Right (pathTransformation, cxtn)) $ mnetBodyTransformation + + -- Render all 16 mtrls in the geom pass. + (mtrlsMeta :: [((WidthHeightI, GLuint), MtrlMeta)], cxtnp2) <- + foldrA cachingRenderMtrlAccum -< (([], cxtnp1), map (\mi -> (swa^.swaSol, mi)) (elems (gp^.gpMv))) + let (mtrlsGlTextures :: [GLuint]) = map (fst >>> snd) mtrlsMeta + let (assignTextures :: GLIOF ()) = do + forM_ (zip [0..] mtrlsGlTextures) $ \(idx, glTexture) -> do + case flip M.lookup numToGL_TEXTUREi idx of + Nothing -> return () + Just gl_TEXTUREi -> do + -- Apparently actually we set GL_TEXTUREi for the texture() + -- GLSL call, not the texture name. So set the i used in + -- GL_TEXTUREi as the value, not the texture identifier. + --GLUniform1i (fromIntegral idx) (fromIntegral texture) () + GLUniform1i (fromIntegral idx) (fromIntegral idx) () + + --GLActiveTexture GL_TEXTUREi () + GLActiveTexture gl_TEXTUREi () + GLBindTexture GL_TEXTURE_2D glTexture () + + -- Render all geometry in this geom pass. + (melemVaoVboEbo, cxtnp3) <- getElemVaoVboEbo -< cxtnp2 + let elemVaoVboEbo = fromMaybe (error "Internal error: renderGeomPass expected elem vao and buf to be present, but it's missing!") melemVaoVboEbo + let (elemVao, _elemVbo, _elemEbo) = elemVaoVboEbo + let (renderGeomPassScene :: GLIOF ()) = do + -- Tell the shaders to enable the scene data. + GLUniform1i shaderEnableSceneDataLocation trueAsIntegral () + -- Tell the shaders we are not drawing the ball right now. + GLUniform1i shaderEnableBallDataLocation falseAsIntegral () + + -- Tell the shaders what geom pass to use. + GLUniform1i (shaderSceneGeomPassIdxLocation) (fromIntegral geomPassIdx) () + + -- Tell the shaders to render this pass's geometries. It will handle the rest; it already has the geom pass data we uploaded upon setup. + GLBindVertexArray elemVao () + + -- Use the vao to tell the shader to draw the geometry. + let numGpGis = rangeSize . bounds $ gp^.gpGis + GLDrawArrays GL_TRIANGLES 0 (fromIntegral (3 * numGpGis)) () + + -- Unbind the VAO. + GLBindVertexArray 0 () + + let (alphaSetup :: GLIOF ()) = do + if isAlpha + then do + GLEnable GL_BLEND () + GLBlendEquationSeparate GL_FUNC_ADD GL_FUNC_ADD () + GLBlendFuncSeparate GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA GL_ONE GL_ZERO () + + GLEnable GL_DEPTH_TEST () + GLDepthMask GL_FALSE () + else do + GLDisable GL_BLEND () + + GLEnable GL_DEPTH_TEST () + GLDepthMask GL_TRUE () + let (alphaFinish :: GLIOF ()) = do + if isAlpha + then do + GLDisable GL_BLEND () + + GLDepthMask GL_TRUE () + else do + GLDisable GL_BLEND () + + GLDepthMask GL_TRUE () + + -- Now aggregate the rendering to render the geom pass. + let (renderGeomPassGL :: GLIOF ()) = do + alphaSetup + assignTextures + renderGeomPassScene + alphaFinish + () <- monadic -< sdlGL1' renderGeomPassGL + + -- Return the state context. + let cxt = cxtnp3 + returnA -< cxt + + where + -- | Add 2 variants: lookup sol mtrl for path, and also accumulate results in a list. + cachingRenderMtrlAccum :: Wire ImmutaballM ((LevelIB, Int32), ([((WidthHeightI, GLuint), MtrlMeta)], IBStateContext)) ([((WidthHeightI, GLuint), MtrlMeta)], IBStateContext) + cachingRenderMtrlAccum = proc ((sol, mi), (accum_, cxtn)) -> do + let mtrl = (sol^.solMv) ! mi + let mtrlPath = mtrl^.mtrlF + (glTextureMeta, cxtnp1) <- cachingRenderMtrl -< (mtrlPath, cxtn) + returnA -< (glTextureMeta:accum_, cxtnp1) diff --git a/Immutaball/Ball/State/Game.hs b/Immutaball/Ball/State/Game.hs --- a/Immutaball/Ball/State/Game.hs +++ b/Immutaball/Ball/State/Game.hs @@ -5,913 +5,1958 @@ -- Play.hs. {-# LANGUAGE Haskell2010 #-} -{-# LANGUAGE TemplateHaskell, Arrows, ScopedTypeVariables #-} - --- | Game state and immutaball state interface. -module Immutaball.Ball.State.Game - ( - GameRequest(..), giRequest, giGameState, giIBStateContext, grRequest, - GameResponse(..), goGameEvents, goGameState, goIBStateContext, grGameEvents, - GameEvent(..), AsGameEvent(..), - stepGame, - renderBall, - renderBallSetup, - stepGameInput, - stepGameInputMovement, - stepGameInputEvents, - stepGameClock, - stepGameClockDebugFreeCamera, - stepGameBallPhysics, - physicsBallAdvance, - physicsBallAdvanceStationary, - physicsBallAdvanceGhostly, - physicsBallAdvanceBruteForce, - physicsBallAdvanceBruteForceCompute - - -- * Local utils. - ) where - -import Prelude () -import Immutaball.Prelude - -import Control.Monad -import Data.Int -import Data.Foldable -import Data.List -import qualified Data.Map.Lazy as M -import Data.Maybe - -import Control.Arrow -import Control.Lens -import Data.Array.IArray -import Graphics.GL.Compatibility45 ---import Graphics.GL.Core45 -import Graphics.GL.Types -import qualified SDL.Raw.Enum as Raw - -import Immutaball.Ball.Game -import Immutaball.Share.Config -import Immutaball.Share.Context -import Immutaball.Share.ImmutaballIO.GLIO -import Immutaball.Share.Level -import Immutaball.Share.Level.Analysis -import Immutaball.Share.Math -import Immutaball.Share.SDLManager -import Immutaball.Share.State -import Immutaball.Share.State.Context -import Immutaball.Share.Utils -import Immutaball.Share.Video -import Immutaball.Share.Wire - --- TODO: implement. - -data GameRequest = GameRequest { - _giRequest :: Request, - _giGameState :: GameState, - _giIBStateContext :: IBStateContext -} -makeLenses ''GameRequest -grRequest :: Lens' GameRequest Request -grRequest = giRequest - -data GameResponse = GameResponse { - _goGameEvents :: [GameEvent], - _goGameState :: GameState, - _goIBStateContext :: IBStateContext -} ---makeLenses ''GameResponse - -data GameEvent = - NewGameMode GameMode - -- | PlaceholderEvent -makeLenses ''GameResponse -makeClassyPrisms ''GameEvent - -grGameEvents :: Lens' GameResponse [GameEvent] -grGameEvents = goGameEvents - --- | Step the game. --- TODO: finish implementing. -stepGame :: Wire ImmutaballM GameRequest GameResponse -stepGame = proc gr -> do - let request = gr^.giRequest - let cxtn = gr^.giIBStateContext - - -- Get starting game state. - let (gsn :: GameState) = (gr^.giGameState) - - -- Handle input (in request). (With many possibly input requests, stepGameInput itself handles delegation of this.) - (gsnp1, cxtnp1) <- stepGameInput -< (gsn, request, cxtn) - - -- Step the game on clock request. (Only one request is clock; handle it here it.) - mdt <- returnA -< const Nothing ||| Just $ matching _Clock request - (gsnp2, cxtnp2) <- returnA ||| stepGameClock -< maybe (Left (gsnp1, cxtnp1)) (\dt -> Right (gsn, dt, cxtnp1)) $ mdt - - -- Identify new game state. - let (gs :: GameState) = gsnp2 - let (cxt :: IBStateContext) = cxtnp2 - - -- Return results. - returnA -< GameResponse { - _goGameEvents = [], -- TODO: detect new game mode. - _goGameState = gs, - _goIBStateContext = cxt - } - -renderBall :: Wire ImmutaballM (GameState, IBStateContext) IBStateContext -renderBall = proc (gs, cxtn) -> do - hasInit <- delay False -< returnA True - cxtnp1 <- arr snd ||| renderBallSetup -< if' hasInit Left Right (gs, cxtn) - - let sdlGL1' = liftIBIO . sdlGL1 (cxtnp1^.ibContext.ibSDLManagerHandle) - - -- Render the ball. - (mballElemVaoVboEbo, cxtnp2) <- getBallElemVaoVboEbo -< cxtnp1 - let ballElemVaoVboEbo = fromMaybe (error "Internal error: renderBall expected elem vao and buf to be present, but it's missing!") mballElemVaoVboEbo - let (ballElemVao, _ballElemVbo, _ballElemEbo) = ballElemVaoVboEbo - - -- TODO: set the transformation matrix explicitly. For now we take - -- advantage of the fact that the transformation matrix hasn't been updated - -- since the scene was drawn (before the ball was), so just conveniently - -- implicitly re-use the transformation matrix in the meantime. - - let (renderBallDirect :: GLIOF ()) = do - -- Tell the shaders to disable the scene data. - GLUniform1i shaderEnableSceneDataLocation falseAsIntegral () - -- Tell the shaders we are drawing the ball right now. - GLUniform1i shaderEnableBallDataLocation trueAsIntegral () - - -- Tell the shaders the ball radius. - let (ballRadiusf :: GLfloat) = realToFrac $ gs^.gsBallRadius - GLUniform1f shaderBallRadiusLocation ballRadiusf () - -- Tell the shaders the ball num triangles. - let (ballNumTriangles :: Integer) = cxtnp2^.ibContext.ibStaticConfig.x'cfgBallTriangles - GLUniform1i shaderBallNumTrianglesLocation (fromIntegral ballNumTriangles) () - -- Tell the shaders the ball position. - let (ballPosX :: GLfloat, ballPosY :: GLfloat, ballPosZ :: GLfloat) = (realToFrac $ gs^.gsBallPos.x3, realToFrac $ gs^.gsBallPos.y3, realToFrac $ gs^.gsBallPos.z3) - GLUniform3f shaderBallPosLocation ballPosX ballPosY ballPosZ () - -- Tell the shaders the ball rotation. - let (ballRotX :: GLfloat, ballRotY :: GLfloat, ballRotZ :: GLfloat) = (realToFrac $ gs^.gsBallRot.x3, realToFrac $ gs^.gsBallRot.y3, realToFrac $ gs^.gsBallRot.z3) - GLUniform3f shaderBallRotLocation ballRotX ballRotY ballRotZ () - - -- Tell the shaders to render the ball's triangles' vertices. The - -- shader for now will just directly draw a basic ball. - -- (TODO: support more than just basic ball.) - GLBindVertexArray ballElemVao () - - -- Use the vao to tell the shader to draw the geometry. - --let (ballNumTriangles :: Integer) = cxtnp2^.ibContext.ibStaticConfig.x'cfgBallTriangles - GLDrawArrays GL_TRIANGLES 0 (fromIntegral (3 * ballNumTriangles)) () - - -- Unbind the VAO. - GLBindVertexArray 0 () - -- We're not using textures for the basic ball; the shader can calculate the color. - let (assignTextures :: GLIOF ()) = return () - -- Enable transparency for the ball. - let (isAlpha :: Bool) = True - let (alphaSetup :: GLIOF ()) = do - if isAlpha - then do - GLEnable GL_BLEND () - GLBlendEquationSeparate GL_FUNC_ADD GL_FUNC_ADD () - GLBlendFuncSeparate GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA GL_ONE GL_ZERO () - - GLEnable GL_DEPTH_TEST () - GLDepthMask GL_FALSE () - else do - GLDisable GL_BLEND () - - GLEnable GL_DEPTH_TEST () - GLDepthMask GL_TRUE () - let (alphaFinish :: GLIOF ()) = do - if isAlpha - then do - GLDisable GL_BLEND () - - GLDepthMask GL_TRUE () - else do - GLDisable GL_BLEND () - - GLDepthMask GL_TRUE () - - let (doRenderBall :: GLIOF ()) = do - alphaSetup - assignTextures - renderBallDirect - alphaFinish - () <- monadic -< sdlGL1' doRenderBall - - let cxt = cxtnp2 - returnA -< cxt - -renderBallSetup :: Wire ImmutaballM (GameState, IBStateContext) IBStateContext -renderBallSetup = proc (_gs0, cxtn) -> do - -- A new game state hasn't had its ball render setup performed yet. - -- Perform setup. - - -- First, set up ball elem vao and vbo. See if a previous setup has - -- already done it. Race conditions are okay here, since setting the ball - -- elem vao would discard an old elem vao in a race properly. - -- (Alternatively, we could also always set it up here since it would only - -- happen on a new game state, but checking probably saves a bit of - -- performance for uploading the VAO.) - (mballElemVaoVboEbo, cxtnp1) <- getBallElemVaoVboEbo -< cxtn - - -- Set up the data, ballElemVaoVboEboDataGPU. - let (ballNumTriangles :: Integer) = cxtnp1^.ibContext.ibStaticConfig.x'cfgBallTriangles - let (ballElemVaoVboEboData :: Array Int32 Int32) = genArray (0, 3 * fromIntegral ballNumTriangles - 1) $ \idx -> idx - let (ballElemVaoVboEboDataGPU :: GLData) = gpuEncodeArray ballElemVaoVboEboData - - -- Upload ball elems vao and buf. (Just returnA the cxtnp1 if there's already a ball VAO.) - cxtnp2 <- arr (^._3) ||| setBallElemVaoVboEbo -< if' (isJust mballElemVaoVboEbo) Left Right (ballElemVaoVboEboDataGPU, True, cxtnp1) - - let cxt = cxtnp2 - returnA -< cxt - --- | Handle input. -stepGameInput :: Wire ImmutaballM (GameState, Request, IBStateContext) (GameState, IBStateContext) -stepGameInput = proc (gsn, request, cxtn) -> do - -- Handle forward, right, etc., movement. - (gsnp1, cxtnp1) <- stepGameInputMovement -< (gsn, request, cxtn) - - -- Handle clicking to start playing, etc. - (gsnp2, cxtnp2) <- stepGameInputEvents -< (gsnp1, request, cxtnp1) - - -- Identify output. - let cxt = cxtnp2 - let gs = gsnp2 - - -- Return. - returnA -< (gs, cxt) - -stepGameInputMovement :: Wire ImmutaballM (GameState, Request, IBStateContext) (GameState, IBStateContext) -stepGameInputMovement = proc (gsn, request, cxtn) -> do - -- Movement. - let update = case request of - (Keybd char down) -> - if' (char == cxtn^.ibNeverballrc.keyForward) (gsInputState.ginsForwardOn .~ down) . - if' (char == cxtn^.ibNeverballrc.keyBackward) (gsInputState.ginsBackwardOn .~ down) . - if' (char == cxtn^.ibNeverballrc.keyLeft) (gsInputState.ginsLeftOn .~ down) . - if' (char == cxtn^.ibNeverballrc.keyRight) (gsInputState.ginsRightOn .~ down) . - if' (char == cxtn^.ibContext.ibStaticConfig.x'cfgVertUpKey) (gsInputState.ginsVertUpOn .~ down) . - if' (char == cxtn^.ibContext.ibStaticConfig.x'cfgVertDownKey) (gsInputState.ginsVertDownOn .~ down) $ - id - (Click _button@Raw.SDL_BUTTON_LEFT down) -> (gsInputState.ginsMouseLeftOn .~ down) - (Click _button@Raw.SDL_BUTTON_RIGHT down) -> (gsInputState.ginsMouseRightOn .~ down) - _ -> id - - let gsnp1 = gsn & update - - -- Toggle debug camera view. - let freeCamToggleUpdate = if' (not $ cxtn^.ibContext.ibStaticConfig.x'cfgDebugFreeCamera) id $ - case request of - (Keybd char True) -> - if' (char == cxtn^.ibContext.ibStaticConfig.x'cfgFreeCameraToggleKey) (gsDebugState.gdsCameraDebugOn %~ not) $ - id - _ -> id - - let gsnp2 = gsnp1 & freeCamToggleUpdate - - -- Free camera aiming. - -- mouse sense gives int in pixels for a full circle rotation, except we also scale rotation amount by curMouseSpeed (the 2 speeds are multiplied (although neverballrc is reciprocal)). - let (curMouseSpeed :: Double) = 4.0 - let (curMouseSense :: Int) = cxtn^.ibNeverballrc.mouseSense - let updateFreeAim = if' (not $ gsnp2^.gsDebugState.gdsCameraDebugOn) id $ case request of - (Point _x _y dx' dy') -> - -- SDL for me reported inverted dy (i.e. SDL's 0,0 at the top-left corner); so invert dy. - let dx = dx' in - let dy = -dy' in - - let (dxd :: Double) = fromIntegral dx in - let (dyd :: Double) = fromIntegral dy in - - let (drawCirclesX :: Double) = dxd / fromIntegral curMouseSense in - let (drawCirclesY :: Double) = dyd / fromIntegral curMouseSense in - - let (drawRadiansX :: Double) = tau * drawCirclesX in - let (drawRadiansY :: Double) = tau * drawCirclesY in - - let (dradiansX :: Double) = curMouseSpeed * drawRadiansX in - let (dradiansY :: Double) = curMouseSpeed * drawRadiansY in - - (gsDebugState.gdsCameraAimRightRadians %~ (+ dradiansX)) . - (gsDebugState.gdsCameraAimUpRadians %~ (+ dradiansY)) . - id - _ -> id - - -- Cap: let net view be capped later in 'mkGameStateAnalysis', since there might already be a vertical aim to target. - -- But also cap here at twice the radius to allow full movement. - let updateCapFreeAimUp = gsDebugState.gdsCameraAimUpRadians %~ (min (2 * tau/2) . max (-2 * tau/2)) - - let gsnp3 = gsnp2 & updateCapFreeAimUp . updateFreeAim - - -- Tilt the world if playing. - -- The config for curMouseSense is interpreted to mean the number of pixels - -- needed to traverse the entire tilt range (2 * x'cfgMaxTilt). - let (mouseTiltModifier :: Double) = 1.0 -- Don't change mouse sensitivity for tilt. - let (mouseSensitivity :: Int) = cxtn^.ibNeverballrc.mouseSense - let (maxTilt :: Double) = cxtn^.ibContext.ibStaticConfig.x'cfgMaxTilt - let updateTiltBase = if' (not . isPlaying $ gsnp1^.gsGameMode) id $ case request of - (Point _x _y dx' dy') -> - -- SDL for me reported inverted dy (i.e. SDL's 0,0 at the top-left corner); so invert dy. - let dx = dx' in - let dy = -dy' in - - let (dxd :: Double) = fromIntegral dx in - let (dyd :: Double) = fromIntegral dy in - - let (dTiltRangesX :: Double) = dxd / fromIntegral mouseSensitivity in - let (dTiltRangesY :: Double) = dyd / fromIntegral mouseSensitivity in - - let (dRawRadiansX :: Double) = tau * dTiltRangesX in - let (dRawRadiansY :: Double) = tau * dTiltRangesY in - - let (dRadiansX :: Double) = mouseTiltModifier * dRawRadiansX in - let (dRadiansY :: Double) = mouseTiltModifier * dRawRadiansY in - - (gsGravityState.gravsTiltRightRadians %~ (+ dRadiansX)) . - (gsGravityState.gravsTiltForwardRadians %~ (+ dRadiansY)) . - id - _ -> id - let updateTiltCap = - (gsGravityState.gravsTiltRightRadians %~ (min maxTilt . max (-maxTilt))) . - (gsGravityState.gravsTiltForwardRadians %~ (min maxTilt . max (-maxTilt))) . - id - let updateTilt = updateTiltCap <<< updateTiltBase - - let gsnp4 = gsnp3 & updateTilt - - -- Identify output. - let gs = gsnp4 - let cxt = cxtn - - -- Return. - returnA -< (gs, cxt) - --- | Handle clicking to start playing, etc. --- TODO: generate event for new game mode. -stepGameInputEvents :: Wire ImmutaballM (GameState, Request, IBStateContext) (GameState, IBStateContext) -stepGameInputEvents = proc (gsn, request, cxtn) -> do - -- Start playing? - let update = if' (gsn^.gsGameMode /= Intermission) id $ case request of - (Click _button@Raw.SDL_BUTTON_LEFT _down@True) -> (gsGameMode .~ Playing) - _ -> id - - let gsnp1 = gsn & update - - -- Identify output. - let gs = gsnp1 - let cxt = cxtn - - -- Return. - returnA -< (gs, cxt) - --- | Step a frame of the game state on clock. -stepGameClock :: Wire ImmutaballM (GameState, Double, IBStateContext) (GameState, IBStateContext) -stepGameClock = proc (gsn, dt, cxtn) -> do - let gsa = mkGameStateAnalysis cxtn gsn - - -- Step debug camera. - (gsnp1, cxtnp1) <- returnA ||| stepGameClockDebugFreeCamera -< - if' (not $ gsn^.gsDebugState.gdsCameraDebugOn) - (Left (gsn, cxtn)) - (Right (gsn, dt, cxtn)) - - -- Advance time elapsed if in play state. - let cxtnp2 = cxtnp1 - let gsnp2 = gsnp1 & - if' (not . isPlaying $ gsnp1^.gsGameMode) - (id) - (gsTimeElapsed %~ (+ dt)) - - -- Respond to left and right mouse down by moving the camera. - rec - lastNetMouseRight <- delay 0 -< netMouseRight - netMouseRight <- returnA -< gsa^.gsaNetMouseRight - - lastIsPlayingState <- delay False -< isPlayingState - isPlayingState <- returnA -< isPlaying $ gsnp2^.gsGameMode - - foundChange <- hold False -< if' ((lastIsPlayingState == isPlayingState) && (lastNetMouseRight /= netMouseRight)) (Just True) Nothing - - let cameraAngleSpeed = 1.0 -- radians per second -- TODO: use neverballrc rotate_slow - let updateCameraAngle = if' (not foundChange || not isPlayingState) id $ - (gsCameraAngle %~ (+ (-fromIntegral netMouseRight) * cameraAngleSpeed * dt)) . - id - let gsnp3 = gsnp2 & updateCameraAngle - let cxtnp3 = cxtnp2 - - -- Physically expend dt to advance the ball's position by its velocity, - -- handling physics collisions. - (gsnp4, cxtnp4) <- returnAWithoutMiddle ||| stepGameBallPhysics -< if' (not isPlayingState) Left Right $ (gsnp3, dt, cxtnp3) - - -- Identify output. - let gs = gsnp4 - let cxt = cxtnp4 - - -- Return. - returnA -< (gs, cxt) - where - returnAWithoutMiddle = arr $ \(a, _b, c) -> (a, c) - --- | Step the debug free camera. --- --- Check whether this mode is enabled before using this wire. -stepGameClockDebugFreeCamera :: Wire ImmutaballM (GameState, Double, IBStateContext) (GameState, IBStateContext) -stepGameClockDebugFreeCamera = proc (gsn, dt, cxtn) -> do - let gsa = mkGameStateAnalysis cxtn gsn - let netMov = gsa^.gsaNetRightForwardJump - let (netRight, netForward, netJump) = netMov - - -- FRP architecture note: we have access to both 1) local state (FRP) and - -- 2) the relatively global game state. If we wanted, we could use FRP to - -- make a wire (time-varying value) that outputs the free camera position - -- offset value, and just unconditionally set the game state, disregarding - -- its input. We could also instead not use FRP but just calculate the - -- next state. - -- - -- To demonstrate capabilities, I instead take a third, hybrid approach: - -- both. Use FRP to calculate a diff locally, and then apply that diff to - -- the state (relatively) globally. - - let (unrotatedNetMovementVec :: Vec3 Double) = Vec3 (fromIntegral netRight) (fromIntegral netForward) (fromIntegral netJump) - let (netMovementVec :: Vec3 Double) = tilt3ySimple (v3normalize $ (gsa^.gsaView.mviewTarget) `minusv3` (gsa^.gsaView.mviewPos)) `mv3` unrotatedNetMovementVec - -- relativeNetMovementVec is not needed: netMovementVec _already_ includes the free camera rotation, not just the original orientation in the level file. - --let (relativeNetMovementVec :: Vec3 Double) = aimVert3DSimple (Just $ 0.99*tau) (gsn^.gsDebugState.gdsCameraAimUpRadians) . aimHoriz3DSimple (gsn^.gsDebugState.gdsCameraAimRightRadians) $ netMovementVec - let netMovementVec' = if' (not freeCameraRelative) unrotatedNetMovementVec $ netMovementVec - posOffset <- integrate zv3 -< (dt * freeCameraSpeed) `sv3` netMovementVec' - - -- FRP (local). - posOffsetDiff <- differentiate -< posOffset - -- State (global). - let posOffsetUpdate = gsDebugState.gdsCameraPosOffset %~ (+ posOffsetDiff) - let gsnp1 = gsn & posOffsetUpdate - - -- Identity output. - let gs = gsnp1 - let cxt = cxtn - - -- Return. - returnA -< (gs, cxt) - - where - -- Units per second. - freeCameraSpeed :: Double - freeCameraSpeed = 2.0 - - -- Relative to aim? This is normal behavior, but temporarily setting - -- this to False is an option. - freeCameraRelative :: Bool - freeCameraRelative = True - --- | Expend dt to step the ball through the physical world. --- --- Apply gravity and handle collisions. -stepGameBallPhysics :: Wire ImmutaballM (GameState, Double, IBStateContext) (GameState, IBStateContext) -stepGameBallPhysics = proc (gsn, dt, cxtn) -> do - let gsa = mkGameStateAnalysis cxtn gsn - - let x'cfg = cxtn^.ibContext.ibStaticConfig - - -- Find the gravity vector. - let gravityVectorUnrotated = (gsa^.gsaUpVec) & z3 %~ negate -- Mirror on xy plane. - let gravityVector = rotatexySimple (gsn^.gsCameraAngle) `mv3` gravityVectorUnrotated - -- Don't apply the gravity vector yet, since we might apply too much dt, - -- e.g. before the ball rests back on the floor; this could make the ball - -- bouncy, especially depending on the frame rate. - {- - let gravityAcceleration = x'cfg^.x'cfgGravity - let updateGravity = - (gsBallVel %~ (+ (dt * gravityAcceleration) `sv3` gravityVector)) . - id - let gsnp1 = gsn & updateGravity - -} - let gsnp1 = gsn - let cxtnp1 = cxtn - - -- Advance the ball through the physical world, handling collisions. - -- - -- Expend dt to apply its velocity to the position, handling collisions by - -- applying reflections. - let (ballPos', ballVel') = physicsBallAdvance x'cfg (gsnp1^.gsSol) (gsnp1^.gsSolAnalysis.saPhysicsAnalysis) (gsnp1^.gsBallRadius) gravityVector dt (gsnp1^.gsBallPos) (gsnp1^.gsBallVel) - let updateBall = - (gsBallPos .~ ballPos') . - (gsBallVel .~ ballVel') . - id - let (gsnp2, cxtnp2) = (gsnp1 & updateBall, cxtnp1) - - -- Identify output. - let gs = gsnp2 - let cxt = cxtnp2 - - -- Return. - returnA -< (gs, cxt) - --- | Expend dt to step the ball through the physical world, handling collisions. -physicsBallAdvance :: StaticConfig -> LevelIB -> SolPhysicsAnalysis -> Double -> Vec3 Double -> Double -> Vec3 Double -> Vec3 Double -> (Vec3 Double, Vec3 Double) -physicsBallAdvance x'cfg level spa ballRadius gravityVector dt ballPos ballVel = choice_ x'cfg level spa ballRadius gravityVector dt ballPos ballVel - where - choice_ :: StaticConfig -> LevelIB -> SolPhysicsAnalysis -> Double -> Vec3 Double -> Double -> Vec3 Double -> Vec3 Double -> (Vec3 Double, Vec3 Double) - --choice_ = physicsBallAdvanceStationary - --choice_ = physicsBallAdvanceGhostly - choice_ = physicsBallAdvanceBruteForce - --- | For debugging or performance checking, keep the ball stationary. -physicsBallAdvanceStationary :: StaticConfig -> LevelIB -> SolPhysicsAnalysis -> Double -> Vec3 Double -> Double -> Vec3 Double -> Vec3 Double -> (Vec3 Double, Vec3 Double) -physicsBallAdvanceStationary _x'cfg _level _spa _ballRadius _gravityVector _dt p0 v0 = (p1, v0) - where - p1 = p0 - --- | For debugging or performance checking, ignore all collision checking. -physicsBallAdvanceGhostly :: StaticConfig -> LevelIB -> SolPhysicsAnalysis -> Double -> Vec3 Double -> Double -> Vec3 Double -> Vec3 Double -> (Vec3 Double, Vec3 Double) -physicsBallAdvanceGhostly x'cfg _level _spa _ballRadius gravityVector dt p0 v0 = (p1, v1) - where - p1 = p0 + (dt `sv3` v1) - v1 = v0 + ((dt * gravityAcceleration) `sv3` gravityVector) - gravityAcceleration = x'cfg^.x'cfgGravity - --- | This version completely ignores the BSP. It checks collisions with every --- lump every frame. -physicsBallAdvanceBruteForce :: StaticConfig -> LevelIB -> SolPhysicsAnalysis -> Double -> Vec3 Double -> Double -> Vec3 Double -> Vec3 Double -> (Vec3 Double, Vec3 Double) -physicsBallAdvanceBruteForce = physicsBallAdvanceBruteForceCompute 0 0.0 0.0 - --- | Finish computing 'physicsBallAdvanceBruteFroce'. --- --- Make a line segment from p0 to p1, where p1 is p0 + dt*v, i.e. the tentative --- end-point of the ball's position after the frame, if no collisions occur. --- Check all lumps for a closest collision, and if one is found, expend enough --- dt to advance the ball to the point of intersection, and then reflect v0 --- about the face's plane, and repeat, checking again for all lumps using the --- remaining dt to expend. Since the path represent the center of the ball, --- use the sphere's radius to check for distance. For edges and vertices, use --- as the plane a constructed plane where the plane is orthogonal to the line --- from the (new) ball center to the point of intersection. Once no collisions --- have been detected, freely expend the remaining dt. We now have the new --- ball position, at the last p1. --- --- Parameters: --- --- numCollisions: --- for testing squishes, this is incremented each collision, and once it --- exceeds the maximum, the squish condition is detected and the physics --- engine will skip any remaining collisions, letting the ball go through lumps. --- thresholdTimeRemaining: --- Once this much dt has been expended, reset the 2 squish detection --- parameters (this and numCollisions). --- thresholdRDistanceRemaining: --- Once the ball has traveled this much distance in terms of ball radiuses, --- reset the squish state in this condition too. We don't want the ball the --- ghost through walls if the frame is slow and processing a lot of dt at --- once, simply because it made many collisions in a frame even though it --- traveled a long distance (e.g. spinning around in a cone if the system --- briefly pauses), so we have thresholdTimeRemaining; and we also have --- distance because otherwise the ball can always go fast enough so that it --- bounces enough times between lumps and ghosts through. -physicsBallAdvanceBruteForceCompute :: Integer -> Double -> Double -> StaticConfig -> LevelIB -> SolPhysicsAnalysis -> Double -> Vec3 Double -> Double -> Vec3 Double -> Vec3 Double -> (Vec3 Double, Vec3 Double) ---physicsBallAdvanceBruteForceCompute numCollisions thresholdTimeRemaining thresholdRDistanceRemaining x'cfg level spa ballRadius gravityVector dt p0 v0 = -physicsBallAdvanceBruteForceCompute numCollisions thresholdTimeRemaining thresholdRDistanceRemaining x'cfg level spa ballRadius gravityVector dt p0 v0 - -- Redundantly ensure dt is not zero or negative. - | dt <= 0 + smallNum = let (p1, v1) = (p0, v0) in (p1, v1) - -- Check the optional maxPhysicsStepTime config. - | Just maxPhysicsStepTime <- x'cfg^.x'cfgMaxPhysicsStepTime, dt > maxPhysicsStepTime + smallNum = - let (p1, v1) = - physicsBallAdvanceBruteForceCompute - numCollisions - thresholdTimeRemaining - thresholdRDistanceRemaining - x'cfg - level - spa - ballRadius - gravityVector - maxPhysicsStepTime - p0 - v0 in - physicsBallAdvanceBruteForceCompute - numCollisions - thresholdTimeRemaining - thresholdRDistanceRemaining - x'cfg - level - spa - ballRadius - gravityVector - (dt - maxPhysicsStepTime) - p1 - v1 - -- Now step the physics. - | otherwise = - case closestLumpIntersecting of -- Find the next collision. - Nothing -> -- No more collisions this frame. - -- Gravity: apply gravity to the rest of the path. - let (p1, v1) = (p0 + (dt `sv3` v0), v0g dt) in (p1, v1) -- Expend the rest of dt after the last collision. - Just (_lastLi', edt, p0', v0') -> -- Found the next collision. Expend ‘edt’ to advance the pall to p0'. - -- Gravity: only apply the gravity vector through to the next collision, later on when we produce what is v0' here. - let travelRDistance = (p0' - p0)^.r3 / ballRadius; trd = travelRDistance in - physicsBallAdvanceBruteForceCompute - ( if' resetSquishState 0 (numCollisions + 1) ) - ( if' resetSquishState (x'cfg^.x'cfgMaxFrameCollisionsDtThreshold - edt) (thresholdTimeRemaining - edt) ) - ( if' resetSquishState (x'cfg^.x'cfgMaxFrameCollisionsRDistanceThreshold - edt) (thresholdRDistanceRemaining - trd) ) - x'cfg - level - spa - ballRadius - gravityVector - (dt - edt) - p0' - v0' - - where - bounceReturn = x'cfg^.x'cfgBounceReturn - gravityAcceleration = x'cfg^.x'cfgGravity - - resetSquishState - | thresholdTimeRemaining <= 0 = True - | thresholdRDistanceRemaining <= 0 = True - | otherwise = False - - -- | Find the closest lump intersecting the ball's path, for collisions. - closestLumpIntersectingRaw :: Maybe (Int32, Double, Vec3 Double, Vec3 Double) - --closestLumpIntersectingRaw = safeHead . sortOn (^._2) . catMaybes . toList $ lumpsIntersecting - closestLumpIntersectingRaw = safeHead . sortOn (^._2) . catMaybes $ lumpsIntersecting - - -- | Check cfgMaxFrameCollisions, and whether dt is already exhausted. - closestLumpIntersecting :: Maybe (Int32, Double, Vec3 Double, Vec3 Double) - closestLumpIntersecting - | numCollisions >= (x'cfg^.x'cfgMaxFrameCollisions) = Nothing - | dt <= 0 || (dt - 0) `equivalentSmall` 0 = Nothing - | otherwise = closestLumpIntersectingRaw - - -- | Map each lump into the closest collision, and get 1) the dt - -- needed to expend to advance the ball to this point of collision, 2) - -- the new ball pos and 3) ball vel. - -- - -- Only the closest collision will be used for advancing the ball, - -- before checking for collision again afterwards. - --lumpsIntersecting :: Array Int32 (Maybe (Double, Vec3 Double, Vec3 Double)) - --lumpsIntersecting = level^.solLv <&> \lump -> - lumpsIntersecting :: [Maybe (Int32, Double, Vec3 Double, Vec3 Double)] - lumpsIntersecting = flip fmap (zip [0..] (toList $ level^.solLv)) . uncurry $ \li lump -> - let - checkVertices :: Bool - -- I suspect checking the length of facesIntersectingNoBounds - -- can introduce a space leak (e.g. try out retour de force 2), - -- but it turns out probably checking the length of - -- edgesIntersecting is probably better anyway. - --checkVertices | (_:_:_:_) <- facesIntersectingNoBounds = True | otherwise = False - -- TODO FIXME: verify this also isn't broken, but for now just - -- always check verts. - --checkVertices | (_:_:_) <- edgesIntersecting = True | otherwise = False - checkVertices = True - verticesIntersecting :: [(Int32, Double, Vec3 Double, Vec3 Double)] - verticesIntersecting = if' (not checkVertices) [] $ do - -- For each verte, - vi <- indirection <$> [lump^.lumpV0 .. lump^.lumpV0 + lump^.lumpVc - 1] - let vertex = (level^.solVv) ! vi - let v = vertex^.vertP - - -- Find the distance between the path (lp) and the vertex. - let vd = abs $ line3PointDistance lp v - - -- Skip if the _infinite_ line extension from lp and - -- the vertex are too far away. This allows an early check - -- and also to ensure the call to line3DistanceCoordFromPoint is valid. - guard $ vd <= ballRadius - - -- Find the closest point coord on lp to the vertex. - let lpClosestX = line3PointCoord lp v - - -- Find how far away the candidates for x (where the ball - -- is exactly ballRadius away from the vertex) are from - -- closestX. - let lpCoordOffset = line3DistanceCoordFromPoint lp v ballRadius - - -- Find the coord on lp where the distance is the ball's - -- radius. Skip if we have nothing on lp. - let xCandidates = [lpClosestX - lpCoordOffset, lpClosestX + lpCoordOffset] - (x:_) <- return . sort . filter (\x -> 0 <= x + smallNum && x - smallNum <= 1) $ xCandidates - - -- Skip if x is not on lp. (Already done by the filter above.) - --guard $ 0 <= x + smallNum && x - smallNum <= 1 - - -- Find the ball intersection point. - let ballIntersection = line3Lerp lp x `v3orWith` (lp^.p0l3) - - -- For the reflecting plane for the ball's velocity, - -- construct a virtual plane essentially with the vector - -- from the vertex to the ball's position at intersection - -- as normal. - let virtualPlane = normalPlane3 (v3normalize $ ballIntersection - v) 0 - - -- Make sure the ball is going towards the vertex, not away - -- from it, similar to the normal check for planes for - -- avoiding multiple collisions in a single step for me - -- thasme lump. - guard $ (lp^.a0l3) `d3` (virtualPlane^.abcp3) <= 0 - - -- Return the results of this collision, which is used if - -- it is found to be the first potential collision on the - -- path lp. - let edt = x * dt - let p0' = ballIntersection - let v0' = plane3ReflectPointAmount (virtualPlane & dp3 .~ 0) (v0g edt) (bounceReturn) -- v0g: Apply gravity for this path. - return $ (li, edt, p0', v0') - - checkEdges :: Bool - -- TODO FIXME: length >= 2 seems to cause edge collision detection - -- to not work. For now just disable this check. - --checkEdges | (_:_:_) <- facesIntersectingNoBounds = True | otherwise = False - checkEdges = True - edgesIntersecting :: [(Int32, Double, Vec3 Double, Vec3 Double)] - edgesIntersecting = if' (not checkEdges) [] $ do - -- For each edge, - ei <- indirection <$> [lump^.lumpE0 .. lump^.lumpE0 + lump^.lumpEc - 1] - let edge = (level^.solEv) ! ei - let (vi, vj) = (((level^.solVv) ! (edge^.edgeVi))^.vertP, ((level^.solVv) ! (edge^.edgeVj))^.vertP) - let el = line3Points vi vj - - -- Find the distance between the path (lp) and the edge. - let ed = abs $ line3Line3Distance lp el - - -- Skip if _the infinite lines_ are too far away. However, - -- the line segments may still be too far away even if the - -- infinite lines are not, so we'll filter lp coords in [0, 1]. - guard $ ed <= ballRadius - - -- Find the closest point. - Just (lpx, elx) <- return $ line3Line3ClosestCoords lp el - let elv = line3Lerp el elx - - -- Find the point on lp where the ball is at when it first - -- collides with the edge. - let lpCoordOffset = abs $ line3DistanceCoordFromPoint lp elv ballRadius - - -- Find candidates for x: they must be within [0, 1]; if no - -- candidates pass, the line segment (the path) is too far - -- away from the edge, so we'll skip this edge. - let xCandidates = [lpx - lpCoordOffset, lpx + lpCoordOffset] - (x:_) <- return . sort . filter (\x -> 0 <= x + smallNum && x - smallNum <= 1) $ xCandidates - - let ballIntersection = line3Lerp lp x `v3orWith` (lp^.p0l3) - - let edgePointBallIntersection = line3Lerp el . line3PointCoord el $ ballIntersection - - -- Check to make sure the intersection is actually on the - -- edge _line segment_, not to leave it checking its - -- infinite line only! - let intersectionElx = line3PointCoord el edgePointBallIntersection - guard $ 0 <= intersectionElx + smallNum && intersectionElx - smallNum <= 1 - - -- For the reflecting plane for the ball's velocity, - -- construct a virtual plane essentially with the vector - -- from the edge to the ball's position at intersection as - -- normal. - let virtualPlane = normalPlane3 (v3normalize $ ballIntersection - edgePointBallIntersection) 0 - - -- Make sure the ball is going towards the edge, not away - -- from it, similar to the normal check for planes for - -- avoiding multiple collisions in a single step for me - -- thasme lump. - guard $ (lp^.a0l3) `d3` (virtualPlane^.abcp3) <= 0 - - -- Return the results of this collision, which is used if - -- it is found to be the first potential collision on the - -- path lp. - let edt = x * dt - let p0' = ballIntersection - let v0' = plane3ReflectPointAmount (virtualPlane & dp3 .~ 0) (v0g edt) (bounceReturn) -- v0g: Apply gravity for this path. - return $ (li, edt, p0', v0') - - -- | Find all faces that intersect p0->p1. - -- - -- Find where the p0->p1 intersects a side's plane. However, - -- handle the bounds of the face: if the face's plane's point - -- of intersection with p0->p1 is not behind (<=) all other - -- planes, then it's beyond the edges bordering the side. - -- - -- Note this requires that all sides have a normal pointing - -- _away_ from the convex lump inside the level file. - facesIntersecting :: [(Int32, Double, Vec3 Double, Vec3 Double)] - facesIntersecting = facesIntersecting' False - _facesIntersectingNoBounds :: [(Int32, Double, Vec3 Double, Vec3 Double)] - _facesIntersectingNoBounds = facesIntersecting' True - -- | We use ignoreEdgeBounds when checking for edge and vertex - -- intersections. - facesIntersecting' :: Bool -> [(Int32, Double, Vec3 Double, Vec3 Double)] - facesIntersecting' ignoreEdgeBounds = do - let errMsg = "Internal error: physicsBallAdvanceBruteForceCompute: sides data missing for lump with li " ++ (show li) ++ "." - let sidePlanes = flip M.lookup (spa^.spaLumpPlanes) li `morElse` error errMsg - - -- For each side (check useDirectSol for which set of sides to use), - (sidx, sidePlane) <- - if useDirectSol - then do - -- For each side, - si <- indirection <$> [lump^.lumpS0 .. lump^.lumpS0 + lump^.lumpSc - 1] - let side = (level^.solSv) ! si - -- Get its plane. - let sidePlane = normalPlane3 (side^.sideN) (side^.sideD) - return (si, sidePlane) - else do - (sidx, sidePlane) <- zip [0..] sidePlanes - return (sidx, sidePlane) - -- Find where on lp it intersects; abort this try if it doesn't. - Just x <- return $ line3CoordAtDistancePlane3 sidePlane lp ballRadius - -- Only consider intersections on the line segment. - --guard $ (0 <= x + smallNum && x - smallNum <= 1) - -- The right side prevents the ball from ghost-glitching - -- through a wall for very short 'lp' ('onPlaneCheck'). - let intersectsLp = 0 <= x + smallNum && x - smallNum <= 1 - let onPlaneCheck = plane3PointDistance sidePlane (lp^.p0l3) `near` ballRadius && plane3PointDistance sidePlane (lp^.p1l3) `near` ballRadius - guard $ intersectsLp || onPlaneCheck - - -- Get the point in 3D space: this is where the ball would - -- be if advanced to this intersection. - let ballIntersection = line3Lerp lp x `v3orWith` (lp^.p0l3) - -- Get the point on the plane where this collision would - -- take place: the closest point on the plane to - -- 'ballIntersection'. - let planeIntersection = pointToPlane ballIntersection sidePlane - -- Only consider intersections whose plane intersection - -- points are behind all other sides. - guard . (if' ignoreEdgeBounds (const True) id) . and $ do - if useDirectSol - then do - let si = sidx - - -- For every other side … - sj <- [lump^.lumpS0 .. lump^.lumpS0 + lump^.lumpSc - 1] - guard $ sj /= si - let sidej = (level^.solSv) ! sj - let sidejPlane = normalPlane3 (sidej^.sideN) (sidej^.sideD) - - -- Make sure the point is behind this plane. - return $ plane3PointDistance sidejPlane planeIntersection <= 0 - else do - -- For every other side … - (sjidx, sidejPlane) <- zip [0..] sidePlanes - guard $ sjidx /= sidx - - -- Make sure the point is behind this plane. - return $ plane3PointDistance sidejPlane planeIntersection <= 0 - - -- Finally, make sure we only register a collision if the - -- ball is going towards this plane, not away from it: e.g. - -- you can only collide against a top face from above, not - -- from underneath. This prevents the same lump causing - -- multiple collision events for what should be a single - -- collision. We can do this by making sure the dot - -- product of the direction (axis) of ‘lp’ and the plane - -- normal is not positive. - guard $ (lp^.a0l3) `d3` (sidePlane^.abcp3) <= 0 - - -- We've found an intersection. Now calculate the values - -- we would need if we ended up picking this after finding it - -- is indeed the closest. - - let edt = x * dt - let p0' = ballIntersection - let v0' = plane3ReflectPointAmount (sidePlane & dp3 .~ 0) (v0g edt) (bounceReturn) -- v0g: Apply gravity for this path. - return $ (li, edt, p0', v0') - - where - useDirectSol = False - - -- | Lower dimensionalities appear before higher - -- dimensionalities for equal distances. 'sortOn' is a stable - -- sort, so we can use it. - allIntersecting = concat $ - [ - verticesIntersecting, - edgesIntersecting, - facesIntersecting - ] - - sortedIntersecting = sortOn (^._2) $ allIntersecting - - lumpComponentIntersecting :: Maybe (Int32, Double, Vec3 Double, Vec3 Double) - lumpComponentIntersecting = safeHead sortedIntersecting - - -- Make sure the lump isn't the one we last used for collisions. - r = lumpComponentIntersecting - in - r - - where - -- | Draw a line segment from the ball's position (center of - -- sphere) to the tentative end-point if all dt were to be - -- expended now using its current velocity. - -- - -- TODO: double check edge cases of small lp don't cause - -- issues. The guard has a p0 and p1 nearness check, but there - -- might still be issues. - lp = let p1 = p0 + (dt `sv3` v0) in line3Points p0 p1 - - -- | It seems sols have indirection for lump sides, vertices, and - -- edges, but not edge indices to vertices. - indirection :: Int32 -> Int32 - indirection idx = (level^.solIv) ! idx - - v0g edt = v0 + ((edt * gravityAcceleration) `sv3` gravityVector) -- What velocity is if v0 has time added to gravity. +{-# LANGUAGE TemplateHaskell, Arrows, ScopedTypeVariables, NondecreasingIndentation #-} + +-- | Game state and immutaball state interface. +module Immutaball.Ball.State.Game + ( + GameRequest(..), giRequest, giGameState, giIBStateContext, grRequest, + GameResponse(..), goGameEvents, goGameState, goIBStateContext, grGameEvents, + GameEvent(..), AsGameEvent(..), + + NextCollision(..), ncClosestLump, ncCheckLumps, ncDistanceTo, ncTimeTo, + NextCollisionState(..), ncsNc, ncsBspsLeft, + LumpBSPPartitionParent(..), lbspppParent, lbspppIsRightBranch, + LumpLpPlaneIntersection(..), AsLumpLpPlaneIntersection(..), + LumpLpPlaneCommonIntersection(..), llpciPriority, llpciDistance, + llpciTimeTo, llpciLi, llpciBi, llpciBodyTranslation, llpciLp, + llpciIntersection, llpciIntersectionLx, llpciIntersectionBall, + llpciVirtualPlane, + LumpLpPlaneFaceIntersection(..), llpfiPlaneIdx, llpfiPlane, llpfiDistance, + llpfiTimeTo, llpfiLi, llpfiBi, llpfiLp, llpfiBodyTranslation, + llpfiIntersection, llpfiIntersectionLx, llpfiIntersectionBall, + LumpLpPlaneEdgeIntersection(..), llpeiDistance, llpeiTimeTo, llpeiLi, + llpeiBi, llpeiBodyTranslation, llpeiLp, llpeiIntersection, + llpeiIntersectionLx, llpeiIntersectionBall, llpeiVirtualPlane, + LumpLpPlaneVertIntersection(..), llpviDistance, llpviTimeTo, llpviLi, + llpviBi, llpviBodyTranslation, llpviLp, llpviIntersection, + llpviIntersectionLx, llpviIntersectionBall, llpviVirtualPlane, + NextCollisionLump(..), nclLumpi, nclLpPlaneIntersections, + + lpxc, + lpxcomp, + nclcomp, + stepGame, + rendererTransformationMatrix, + renderBall, + renderBallSetup, + stepGameInput, + stepGameInputMovement, + stepGameInputEvents, + stepGameClock, + stepGameClockDebugFreeCamera, + stepGameBallPhysics, + + physicsBallAdvance, + physicsBallAdvanceDefault, + physicsBallAdvanceStationary, + physicsBallAdvanceGhostly, + physicsBallAdvanceBruteForce, + physicsBallAdvanceBruteForceCompute, + + physicsBallAdvanceBSP, + + -- * Utils. + getPathTranslation, + getBodyTranslation + + -- * Local utils. + ) where + +import Prelude () +import Immutaball.Prelude + +import Control.Monad +import Data.Bits +import Data.Int +import Data.Foldable +import Data.Function hiding (id, (.)) +import Data.List +import qualified Data.Map.Lazy as M +import Data.Maybe + +import Control.Arrow +import Control.Lens +import Control.Monad.Trans.Class +import Control.Monad.Trans.State.Lazy +import Data.Array.IArray +import qualified Data.Set as S +import Graphics.GL.Compatibility45 +--import Graphics.GL.Core45 +import Graphics.GL.Types +import qualified SDL.Raw.Enum as Raw + +import Data.LabeledBinTree +import Immutaball.Ball.Game +import Immutaball.Share.Config +import Immutaball.Share.Context +import Immutaball.Share.ImmutaballIO.GLIO +import Immutaball.Share.Level +import Immutaball.Share.Level.Analysis +import Immutaball.Share.Math +import Immutaball.Share.SDLManager +import Immutaball.Share.State +import Immutaball.Share.State.Context +import Immutaball.Share.Utils +import Immutaball.Share.Video +import Immutaball.Share.Wire + +-- TODO: fully implement. + +data GameRequest = GameRequest { + _giRequest :: Request, + _giGameState :: GameState, + _giIBStateContext :: IBStateContext +} +makeLenses ''GameRequest +grRequest :: Lens' GameRequest Request +grRequest = giRequest + +data GameResponse = GameResponse { + _goGameEvents :: [GameEvent], + _goGameState :: GameState, + _goIBStateContext :: IBStateContext +} +--makeLenses ''GameResponse + +data GameEvent = + NewGameMode GameMode + -- | PlaceholderEvent +makeLenses ''GameResponse +makeClassyPrisms ''GameEvent + +grGameEvents :: Lens' GameResponse [GameEvent] +grGameEvents = goGameEvents + +-- | Used by 'physicsBallAdvanceBSP'. +data NextCollision = NextCollision { + _ncClosestLump :: NextCollisionLump, + _ncCheckLumps :: [NextCollisionLump], -- ^ Not necessarily sorted. + _ncDistanceTo :: Double, + _ncTimeTo :: Double +} +--makeLenses ''NextCollision + +-- | Used by 'physicsBallAdvanceBSP'. +data NextCollisionState = NextCollisionState { + _ncsNc :: Maybe NextCollision, + _ncsBspsLeft :: [(Int32, Tree LumpBSPPartition, Maybe LumpBSPPartitionParent)] +} +--makeLenses ''NextCollisionState + +-- | Used by 'physicsBallAdvanceBSP'. +data LumpBSPPartitionParent = LumpBSPPartitionParent { + -- | The parent of this partition. + _lbspppParent :: LumpBSPPartition, + -- | Are we a right branch of the parent, rather than left? + _lbspppIsRightBranch :: Bool +} +--makeLenses ''LumpBSPPartitionParent + +-- | Used by 'physicsBallAdvanceBSP'. +data NextCollisionLump = NextCollisionLump { + _nclLumpi :: Int32, + _nclLpPlaneIntersections :: [LumpLpPlaneIntersection] -- Assumed to be non-empty and sorted. +} +--makeLenses ''NextCollisionLump + +-- | A face, edge, or vertex intersection. +-- See 'LumpLpPlaneFaceIntersection' for more information. +-- +-- Used by 'physicsBallAdvanceBSP'. +data LumpLpPlaneIntersection = + FaceIntersection LumpLpPlaneFaceIntersection + | EdgeIntersection LumpLpPlaneEdgeIntersection + | VertIntersection LumpLpPlaneVertIntersection +--makeClassyPrisms ''LumpLpPlaneIntersection + +-- | Common fields for the 3 types of 'LumpLpPlaneInterection's. +-- +-- Used by 'physicsBallAdvanceBSP'. +data LumpLpPlaneCommonIntersection = LumpLpPlaneCommonIntersection { + -- | The collision type priority: 1 for vertex, 2 for edge, 3 for plane. + -- Lowest priority should be sorted first if 2 intersection points are + -- within threshold distance; otherwise, they should be sorted be distance. + _llpciPriority :: Integer, + -- | The distance along lp to the plane. + _llpciDistance :: Double, + -- | The dt that would be expended to reach the point of intersection. + _llpciTimeTo :: Double, + + -- | The lump index. + _llpciLi :: Int32, + -- | The body index. + _llpciBi :: Int32, + -- | For convenience, store the current body translation (where it is on + -- the path - you can add the base vertices to get the net world coords.) + _llpciBodyTranslation :: Vec3 Double, + + -- | The lp in question (relative body coords; use 'ipb' to go back to world coords). + _llpciLp :: Line3 Double, + -- | The point of intersection on the body, relative to body (use ‘ipb’ to go back). + _llpciIntersection :: Vec3 Double, + + -- | Where on ‘lp’ the intersection happens (0.0 if lp is really small). + _llpciIntersectionLx :: Double, + -- | Where the ball would be positioned at the point of intersection; body coords. + _llpciIntersectionBall :: Vec3 Double, + + -- | The plane, or virtual plane, for the collision. + _llpciVirtualPlane :: Plane3 Double +} +--makeLenses ''LumpLpPlaneCommonIntersection + +-- | When considering an advancement of the ball, for a given lump, and for a +-- given plane on that lump, a value of this type represents information about +-- the intersection of the lp line for the ball and this plane. +-- +-- Used by 'physicsBallAdvanceBSP'. +data LumpLpPlaneFaceIntersection = LumpLpPlaneFaceIntersection { + -- | The lump plane index for the plane in question. + _llpfiPlaneIdx :: Integer, + -- | The plane itself (relative body coords). + _llpfiPlane :: Plane3 Double, + -- | The distance along lp to the plane. + _llpfiDistance :: Double, + -- | The dt that would be expended to reach this point of intersection. + _llpfiTimeTo :: Double, + + -- | The lump index. + _llpfiLi :: Int32, + -- | The body index. + _llpfiBi :: Int32, + -- | For convenience, store the current body translation (where it is on + -- the path - you can add the base vertices to get the net world coords.) + _llpfiBodyTranslation :: Vec3 Double, + + -- | The lp in question (relative body coords; use 'ipb' to go back to world coords). + _llpfiLp :: Line3 Double, + -- | The point of intersection on the body, relative to body (use ‘ipb’ to go back). + _llpfiIntersection :: Vec3 Double, + + -- | Where on ‘lp’ the intersection happens (0.0 if lp is really small). + _llpfiIntersectionLx :: Double, + -- | Where the ball would be positioned at the point of intersection; body coords. + _llpfiIntersectionBall :: Vec3 Double +} +--makeLenses ''LumpLpPlaneFaceIntersection + +-- | Used by 'physicsBallAdvanceBSP'. +data LumpLpPlaneEdgeIntersection = LumpLpPlaneEdgeIntersection { + -- | The distance along lp to the plane. + _llpeiDistance :: Double, + -- | The dt that would be expended to reach the point of intersection. + _llpeiTimeTo :: Double, + + -- | The lump index. + _llpeiLi :: Int32, + -- | The body index. + _llpeiBi :: Int32, + -- | For convenience, store the current body translation (where it is on + -- the path - you can add the base vertices to get the net world coords.) + _llpeiBodyTranslation :: Vec3 Double, + + -- | The lp in question (relative body coords; use 'ipb' to go back to world coords). + _llpeiLp :: Line3 Double, + -- | The point of intersection on the body, relative to body (use ‘ipb’ to go back). + _llpeiIntersection :: Vec3 Double, + + -- | Where on ‘lp’ the intersection happens (0.0 if lp is really small). + _llpeiIntersectionLx :: Double, + -- | Where the ball would be positioned at the point of intersection; body coords. + _llpeiIntersectionBall :: Vec3 Double, + + -- | The plane, or virtual plane, for the collision. + _llpeiVirtualPlane :: Plane3 Double +} +--makeLenses ''LumpLpPlaneEdgeIntersection + +-- | Used by 'physicsBallAdvanceBSP'. +data LumpLpPlaneVertIntersection = LumpLpPlaneVertIntersection { + -- | The distance along lp to the plane. + _llpviDistance :: Double, + -- | The dt that would be expended to reach the point of intersection. + _llpviTimeTo :: Double, + + -- | The lump index. + _llpviLi :: Int32, + -- | The body index. + _llpviBi :: Int32, + -- | For convenience, store the current body translation (where it is on + -- the path - you can add the base vertices to get the net world coords.) + _llpviBodyTranslation :: Vec3 Double, + + -- | The lp in question (relative body coords; use 'ipb' to go back to world coords). + _llpviLp :: Line3 Double, + -- | The point of intersection on the body, relative to body (use ‘ipb’ to go back). + _llpviIntersection :: Vec3 Double, + + -- | Where on ‘lp’ the intersection happens (0.0 if lp is really small). + _llpviIntersectionLx :: Double, + -- | Where the ball would be positioned at the point of intersection; body coords. + _llpviIntersectionBall :: Vec3 Double, + + -- | The plane, or virtual plane, for the collision. + _llpviVirtualPlane :: Plane3 Double +} +--makeLenses ''LumpLpPlaneVertIntersection + +makeLenses ''NextCollision +makeLenses ''NextCollisionState +makeLenses ''LumpBSPPartitionParent +makeClassyPrisms ''LumpLpPlaneIntersection +makeLenses ''LumpLpPlaneCommonIntersection +makeLenses ''LumpLpPlaneFaceIntersection +makeLenses ''LumpLpPlaneEdgeIntersection +makeLenses ''LumpLpPlaneVertIntersection +makeLenses ''NextCollisionLump + +-- | Access lump lp plane intersections through a common interface. +-- +-- Pseudo-lens, since priority updates are ignored. +-- +-- Used by 'physicsBallAdvanceBSP'. +lpxc :: Lens' LumpLpPlaneIntersection LumpLpPlaneCommonIntersection +lpxc = lens getter (flip setter) + where + getter :: LumpLpPlaneIntersection -> LumpLpPlaneCommonIntersection + getter (FaceIntersection lpx) = LumpLpPlaneCommonIntersection { + _llpciPriority = 3, + _llpciDistance = lpx^.llpfiDistance, + _llpciTimeTo = lpx^.llpfiTimeTo, + + _llpciLi = lpx^.llpfiLi, + _llpciBi = lpx^.llpfiBi, + _llpciBodyTranslation = lpx^.llpfiBodyTranslation, + + _llpciLp = lpx^.llpfiLp, + _llpciIntersection = lpx^.llpfiIntersection, + + _llpciIntersectionLx = lpx^.llpfiIntersectionLx, + _llpciIntersectionBall = lpx^.llpfiIntersectionBall, + + _llpciVirtualPlane = lpx^.llpfiPlane + } + getter (EdgeIntersection lpx) = LumpLpPlaneCommonIntersection { + _llpciPriority = 2, + _llpciDistance = lpx^.llpeiDistance, + _llpciTimeTo = lpx^.llpeiTimeTo, + + _llpciLi = lpx^.llpeiLi, + _llpciBi = lpx^.llpeiBi, + _llpciBodyTranslation = lpx^.llpeiBodyTranslation, + + _llpciLp = lpx^.llpeiLp, + _llpciIntersection = lpx^.llpeiIntersection, + + _llpciIntersectionLx = lpx^.llpeiIntersectionLx, + _llpciIntersectionBall = lpx^.llpeiIntersectionBall, + + _llpciVirtualPlane = lpx^.llpeiVirtualPlane + } + getter (VertIntersection lpx) = LumpLpPlaneCommonIntersection { + _llpciPriority = 1, + _llpciDistance = lpx^.llpviDistance, + _llpciTimeTo = lpx^.llpviTimeTo, + + _llpciLi = lpx^.llpviLi, + _llpciBi = lpx^.llpviBi, + _llpciBodyTranslation = lpx^.llpviBodyTranslation, + + _llpciLp = lpx^.llpviLp, + _llpciIntersection = lpx^.llpviIntersection, + + _llpciIntersectionLx = lpx^.llpviIntersectionLx, + _llpciIntersectionBall = lpx^.llpviIntersectionBall, + + _llpciVirtualPlane = lpx^.llpviVirtualPlane + } + setter :: LumpLpPlaneCommonIntersection -> LumpLpPlaneIntersection -> LumpLpPlaneIntersection + setter c (FaceIntersection lpx) = FaceIntersection $ lpx & + (llpfiDistance .~ (c^.llpciDistance) ) . + (llpfiTimeTo .~ (c^.llpciTimeTo) ) . + + (llpfiLi .~ (c^.llpciLi) ) . + (llpfiBi .~ (c^.llpciBi) ) . + (llpfiBodyTranslation .~ (c^.llpciBodyTranslation) ) . + + (llpfiLp .~ (c^.llpciLp) ) . + (llpfiIntersection .~ (c^.llpciIntersection) ) . + + (llpfiIntersectionLx .~ (c^.llpciIntersectionLx) ) . + (llpfiIntersectionBall .~ (c^.llpciIntersectionBall)) . + + (llpfiPlane .~ (c^.llpciVirtualPlane) ) . + + id + setter c (EdgeIntersection lpx) = EdgeIntersection $ lpx & + (llpeiDistance .~ (c^.llpciDistance )) . + (llpeiTimeTo .~ (c^.llpciTimeTo )) . + + (llpeiLi .~ (c^.llpciLi )) . + (llpeiBi .~ (c^.llpciBi )) . + (llpeiBodyTranslation .~ (c^.llpciBodyTranslation )) . + + (llpeiLp .~ (c^.llpciLp )) . + (llpeiIntersection .~ (c^.llpciIntersection )) . + + (llpeiIntersectionLx .~ (c^.llpciIntersectionLx )) . + (llpeiIntersectionBall .~ (c^.llpciIntersectionBall)) . + + (llpeiVirtualPlane .~ (c^.llpciVirtualPlane )) . + + id + setter c (VertIntersection lpx) = VertIntersection $ lpx & + (llpviDistance .~ (c^.llpciDistance )) . + (llpviTimeTo .~ (c^.llpciTimeTo )) . + + (llpviLi .~ (c^.llpciLi )) . + (llpviBi .~ (c^.llpciBi )) . + (llpviBodyTranslation .~ (c^.llpciBodyTranslation )) . + + (llpviLp .~ (c^.llpciLp )) . + (llpviIntersection .~ (c^.llpciIntersection )) . + + (llpviIntersectionLx .~ (c^.llpciIntersectionLx )) . + (llpviIntersectionBall .~ (c^.llpciIntersectionBall)) . + + (llpviVirtualPlane .~ (c^.llpciVirtualPlane )) . + + id + +-- | Compare two collisions mostly by distance (see priorities note in +-- 'LumpLpPlaneCommonIntersection'). +-- +-- Used by 'physicsBallAdvanceBSP'. +lpxcomp :: LumpLpPlaneIntersection -> LumpLpPlaneIntersection -> Ordering +lpxcomp a b + | (abs $ a'^.llpciDistance - b'^.llpciDistance) <= smallishNum = + (a'^.llpciPriority, a'^.llpciDistance) `compare` (b'^.llpciPriority, b'^.llpciDistance) + | otherwise = + (a'^.llpciDistance) `compare` (b'^.llpciDistance) + where + (a', b') = (a^.lpxc, b^.lpxc) + +-- | Convenience utility to to compare through 'lpxcomp' 2 valid +-- 'NextCollisionLumps'. (Since they're valid, the list must be sorted and +-- non-empty. +-- +-- Used by 'physicsBallAdvanceBSP'. +nclcomp :: NextCollisionLump -> NextCollisionLump -> Ordering +nclcomp a b + | (alpx:_) <- a^.nclLpPlaneIntersections + , (blpx:_) <- b^.nclLpPlaneIntersections = + alpx `lpxcomp` blpx + | otherwise = error "Error: nclcomp: assumptions of non-empty lists are violated!" + +-- | Step the game. +-- TODO: finish implementing. +stepGame :: Wire ImmutaballM GameRequest GameResponse +stepGame = proc gr -> do + let request = gr^.giRequest + let cxtn = gr^.giIBStateContext + + -- Get starting game state. + let (gsn :: GameState) = (gr^.giGameState) + + -- Handle input (in request). (With many possibly input requests, stepGameInput itself handles delegation of this.) + (gsnp1, cxtnp1) <- stepGameInput -< (gsn, request, cxtn) + + -- Step the game on clock request. (Only one request is clock; handle it here it.) + mdt <- returnA -< const Nothing ||| Just $ matching _Clock request + (gsnp2, cxtnp2) <- returnA ||| stepGameClock -< maybe (Left (gsnp1, cxtnp1)) (\dt -> Right (gsn, dt, cxtnp1)) $ mdt + + -- Identify new game state. + let (gs :: GameState) = gsnp2 + let (cxt :: IBStateContext) = cxtnp2 + + -- Return results. + returnA -< GameResponse { + _goGameEvents = [], -- TODO: detect new game mode. + _goGameState = gs, + _goIBStateContext = cxt + } + +-- | Get a matrix that converts from world coordinates to OpenGL coordinates +-- given the view. +rendererTransformationMatrix :: IBStateContext -> GameState -> MView -> Mat4 Double +rendererTransformationMatrix cxt gs view_ = worldToGL <> rescaleDepth depthScale 0 <> viewMat' viewCollapse view_ <> tilt + where + x'cfg = cxt^.ibContext.ibStaticConfig + depthScale = x'cfg^.x'cfgDepthScale + viewCollapse = x'cfg^.x'cfgViewCollapse + + -- Translate to the ball (negated actually), rotate by gsCameraAngle, tilt3z, and untranslate. + tilt = + translate3 (gs^.gsBallPos) <> -- Finally, undo the first translation. + tilt3z (gsa^.gsaUpVec) <> -- Tilt the world. + rotatexy (-gs^.gsCameraAngle) <> -- Rotate camera. + translate3 (-gs^.gsBallPos) -- First, go to ball (negated actually). + gsa = mkGameStateAnalysis cxt gs + +renderBall :: Wire ImmutaballM ((MView, GameState), IBStateContext) IBStateContext +renderBall = proc ((camera_, gs), cxtn) -> do + hasInit <- delay False -< returnA True + cxtnp1 <- arr snd ||| renderBallSetup -< if' hasInit Left Right (gs, cxtn) + + let sdlGL1' = liftIBIO . sdlGL1 (cxtnp1^.ibContext.ibSDLManagerHandle) + + -- Render the ball. + (mballElemVaoVboEbo, cxtnp2) <- getBallElemVaoVboEbo -< cxtnp1 + let ballElemVaoVboEbo = fromMaybe (error "Internal error: renderBall expected elem vao and buf to be present, but it's missing!") mballElemVaoVboEbo + let (ballElemVao, _ballElemVbo, _ballElemEbo) = ballElemVaoVboEbo + + -- Set the transformation matrix for the ball. + mat <- arr $ uncurry3 rendererTransformationMatrix -< (cxtnp2, gs, camera_) + cxtnp3 <- setTransformation -< (mat, cxtnp2) + + let (renderBallDirect :: GLIOF ()) = do + -- Tell the shaders to disable the scene data. + GLUniform1i shaderEnableSceneDataLocation falseAsIntegral () + -- Tell the shaders we are drawing the ball right now. + GLUniform1i shaderEnableBallDataLocation trueAsIntegral () + + -- Tell the shaders the ball radius. + let (ballRadiusf :: GLfloat) = realToFrac $ gs^.gsBallRadius + GLUniform1f shaderBallRadiusLocation ballRadiusf () + -- Tell the shaders the ball num triangles. + let (ballNumTriangles :: Integer) = cxtnp3^.ibContext.ibStaticConfig.x'cfgBallTriangles + GLUniform1i shaderBallNumTrianglesLocation (fromIntegral ballNumTriangles) () + -- Tell the shaders the ball position. + let (ballPosX :: GLfloat, ballPosY :: GLfloat, ballPosZ :: GLfloat) = (realToFrac $ gs^.gsBallPos.x3, realToFrac $ gs^.gsBallPos.y3, realToFrac $ gs^.gsBallPos.z3) + GLUniform3f shaderBallPosLocation ballPosX ballPosY ballPosZ () + -- Tell the shaders the ball rotation. + let (ballRotX :: GLfloat, ballRotY :: GLfloat, ballRotZ :: GLfloat) = (realToFrac $ gs^.gsBallRot.x3, realToFrac $ gs^.gsBallRot.y3, realToFrac $ gs^.gsBallRot.z3) + GLUniform3f shaderBallRotLocation ballRotX ballRotY ballRotZ () + + -- Tell the shaders to render the ball's triangles' vertices. The + -- shader for now will just directly draw a basic ball. + -- (TODO: support more than just basic ball.) + GLBindVertexArray ballElemVao () + + -- Use the vao to tell the shader to draw the geometry. + --let (ballNumTriangles :: Integer) = cxtnp3^.ibContext.ibStaticConfig.x'cfgBallTriangles + GLDrawArrays GL_TRIANGLES 0 (fromIntegral (3 * ballNumTriangles)) () + + -- Unbind the VAO. + GLBindVertexArray 0 () + -- We're not using textures for the basic ball; the shader can calculate the color. + let (assignTextures :: GLIOF ()) = return () + -- Enable transparency for the ball. + let (isAlpha :: Bool) = True + let (alphaSetup :: GLIOF ()) = do + if isAlpha + then do + GLEnable GL_BLEND () + GLBlendEquationSeparate GL_FUNC_ADD GL_FUNC_ADD () + GLBlendFuncSeparate GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA GL_ONE GL_ZERO () + + GLEnable GL_DEPTH_TEST () + GLDepthMask GL_FALSE () + else do + GLDisable GL_BLEND () + + GLEnable GL_DEPTH_TEST () + GLDepthMask GL_TRUE () + let (alphaFinish :: GLIOF ()) = do + if isAlpha + then do + GLDisable GL_BLEND () + + GLDepthMask GL_TRUE () + else do + GLDisable GL_BLEND () + + GLDepthMask GL_TRUE () + + let (doRenderBall :: GLIOF ()) = do + alphaSetup + assignTextures + renderBallDirect + alphaFinish + () <- monadic -< sdlGL1' doRenderBall + + let cxt = cxtnp3 + returnA -< cxt + +renderBallSetup :: Wire ImmutaballM (GameState, IBStateContext) IBStateContext +renderBallSetup = proc (_gs0, cxtn) -> do + -- A new game state hasn't had its ball render setup performed yet. + -- Perform setup. + + -- First, set up ball elem vao and vbo. See if a previous setup has + -- already done it. Race conditions are okay here, since setting the ball + -- elem vao would discard an old elem vao in a race properly. + -- (Alternatively, we could also always set it up here since it would only + -- happen on a new game state, but checking probably saves a bit of + -- performance for uploading the VAO.) + (mballElemVaoVboEbo, cxtnp1) <- getBallElemVaoVboEbo -< cxtn + + -- Set up the data, ballElemVaoVboEboDataGPU. + let (ballNumTriangles :: Integer) = cxtnp1^.ibContext.ibStaticConfig.x'cfgBallTriangles + let (ballElemVaoVboEboData :: Array Int32 Int32) = genArray (0, 3 * fromIntegral ballNumTriangles - 1) $ \idx -> idx + let (ballElemVaoVboEboDataGPU :: GLData) = gpuEncodeArray ballElemVaoVboEboData + + -- Upload ball elems vao and buf. (Just returnA the cxtnp1 if there's already a ball VAO.) + cxtnp2 <- arr (^._3) ||| setBallElemVaoVboEbo -< if' (isJust mballElemVaoVboEbo) Left Right (ballElemVaoVboEboDataGPU, True, cxtnp1) + + let cxt = cxtnp2 + returnA -< cxt + +-- | Handle input. +stepGameInput :: Wire ImmutaballM (GameState, Request, IBStateContext) (GameState, IBStateContext) +stepGameInput = proc (gsn, request, cxtn) -> do + -- Handle forward, right, etc., movement. + (gsnp1, cxtnp1) <- stepGameInputMovement -< (gsn, request, cxtn) + + -- Handle clicking to start playing, etc. + (gsnp2, cxtnp2) <- stepGameInputEvents -< (gsnp1, request, cxtnp1) + + -- Identify output. + let cxt = cxtnp2 + let gs = gsnp2 + + -- Return. + returnA -< (gs, cxt) + +stepGameInputMovement :: Wire ImmutaballM (GameState, Request, IBStateContext) (GameState, IBStateContext) +stepGameInputMovement = proc (gsn, request, cxtn) -> do + -- Movement. + let update = case request of + (Keybd char down) -> + if' (char == cxtn^.ibNeverballrc.keyForward) (gsInputState.ginsForwardOn .~ down) . + if' (char == cxtn^.ibNeverballrc.keyBackward) (gsInputState.ginsBackwardOn .~ down) . + if' (char == cxtn^.ibNeverballrc.keyLeft) (gsInputState.ginsLeftOn .~ down) . + if' (char == cxtn^.ibNeverballrc.keyRight) (gsInputState.ginsRightOn .~ down) . + if' (char == cxtn^.ibContext.ibStaticConfig.x'cfgVertUpKey) (gsInputState.ginsVertUpOn .~ down) . + if' (char == cxtn^.ibContext.ibStaticConfig.x'cfgVertDownKey) (gsInputState.ginsVertDownOn .~ down) $ + id + (Click _button@Raw.SDL_BUTTON_LEFT down) -> (gsInputState.ginsMouseLeftOn .~ down) + (Click _button@Raw.SDL_BUTTON_RIGHT down) -> (gsInputState.ginsMouseRightOn .~ down) + _ -> id + + let gsnp1 = gsn & update + + -- Toggle debug camera view. + let freeCamToggleUpdate = if' (not $ cxtn^.ibContext.ibStaticConfig.x'cfgDebugFreeCamera) id $ + case request of + (Keybd char True) -> + if' (char == cxtn^.ibContext.ibStaticConfig.x'cfgFreeCameraToggleKey) (gsDebugState.gdsCameraDebugOn %~ not) $ + id + _ -> id + + let gsnp2 = gsnp1 & freeCamToggleUpdate + + -- Free camera aiming. + -- mouse sense gives int in pixels for a full circle rotation, except we also scale rotation amount by curMouseSpeed (the 2 speeds are multiplied (although neverballrc is reciprocal)). + let (curMouseSpeed :: Double) = 4.0 + let (curMouseSense :: Int) = cxtn^.ibNeverballrc.mouseSense + let updateFreeAim = if' (not $ gsnp2^.gsDebugState.gdsCameraDebugOn) id $ case request of + (Point _x _y dx' dy') -> + -- SDL for me reported inverted dy (i.e. SDL's 0,0 at the top-left corner); so invert dy. + let dx = dx' in + let dy = -dy' in + + let (dxd :: Double) = fromIntegral dx in + let (dyd :: Double) = fromIntegral dy in + + let (drawCirclesX :: Double) = dxd / fromIntegral curMouseSense in + let (drawCirclesY :: Double) = dyd / fromIntegral curMouseSense in + + let (drawRadiansX :: Double) = tau * drawCirclesX in + let (drawRadiansY :: Double) = tau * drawCirclesY in + + let (dradiansX :: Double) = curMouseSpeed * drawRadiansX in + let (dradiansY :: Double) = curMouseSpeed * drawRadiansY in + + (gsDebugState.gdsCameraAimRightRadians %~ (+ dradiansX)) . + (gsDebugState.gdsCameraAimUpRadians %~ (+ dradiansY)) . + id + _ -> id + + -- Cap: let net view be capped later in 'mkGameStateAnalysis', since there might already be a vertical aim to target. + -- But also cap here at twice the radius to allow full movement. + let updateCapFreeAimUp = gsDebugState.gdsCameraAimUpRadians %~ (min (2 * tau/2) . max (-2 * tau/2)) + + let gsnp3 = gsnp2 & updateCapFreeAimUp . updateFreeAim + + -- Tilt the world if playing. + -- The config for curMouseSense is interpreted to mean the number of pixels + -- needed to traverse the entire tilt range (2 * x'cfgMaxTilt). + let (mouseTiltModifier :: Double) = 1.0 -- Don't change mouse sensitivity for tilt. + let (mouseSensitivity :: Int) = cxtn^.ibNeverballrc.mouseSense + let (maxTilt :: Double) = cxtn^.ibContext.ibStaticConfig.x'cfgMaxTilt + let updateTiltBase = if' (not . isPlaying $ gsnp1^.gsGameMode) id $ case request of + (Point _x _y dx' dy') -> + -- SDL for me reported inverted dy (i.e. SDL's 0,0 at the top-left corner); so invert dy. + let dx = dx' in + let dy = -dy' in + + let (dxd :: Double) = fromIntegral dx in + let (dyd :: Double) = fromIntegral dy in + + let (dTiltRangesX :: Double) = dxd / fromIntegral mouseSensitivity in + let (dTiltRangesY :: Double) = dyd / fromIntegral mouseSensitivity in + + let (dRawRadiansX :: Double) = tau * dTiltRangesX in + let (dRawRadiansY :: Double) = tau * dTiltRangesY in + + let (dRadiansX :: Double) = mouseTiltModifier * dRawRadiansX in + let (dRadiansY :: Double) = mouseTiltModifier * dRawRadiansY in + + (gsGravityState.gravsTiltRightRadians %~ (+ dRadiansX)) . + (gsGravityState.gravsTiltForwardRadians %~ (+ dRadiansY)) . + id + _ -> id + let updateTiltCap = + (gsGravityState.gravsTiltRightRadians %~ (min maxTilt . max (-maxTilt))) . + (gsGravityState.gravsTiltForwardRadians %~ (min maxTilt . max (-maxTilt))) . + id + let updateTilt = updateTiltCap <<< updateTiltBase + + let gsnp4 = gsnp3 & updateTilt + + -- Identify output. + let gs = gsnp4 + let cxt = cxtn + + -- Return. + returnA -< (gs, cxt) + +-- | Handle clicking to start playing, etc. +-- TODO: generate event for new game mode. +stepGameInputEvents :: Wire ImmutaballM (GameState, Request, IBStateContext) (GameState, IBStateContext) +stepGameInputEvents = proc (gsn, request, cxtn) -> do + -- Start playing? + let update = if' (gsn^.gsGameMode /= Intermission) id $ case request of + (Click _button@Raw.SDL_BUTTON_LEFT _down@True) -> (gsGameMode .~ Playing) + _ -> id + + let gsnp1 = gsn & update + + -- Identify output. + let gs = gsnp1 + let cxt = cxtn + + -- Return. + returnA -< (gs, cxt) + +-- | Step a frame of the game state on clock. +stepGameClock :: Wire ImmutaballM (GameState, Double, IBStateContext) (GameState, IBStateContext) +stepGameClock = proc (gsn, dt, cxtn) -> do + let gsa = mkGameStateAnalysis cxtn gsn + + -- Step debug camera. + (gsnp1, cxtnp1) <- returnA ||| stepGameClockDebugFreeCamera -< + if' (not $ gsn^.gsDebugState.gdsCameraDebugOn) + (Left (gsn, cxtn)) + (Right (gsn, dt, cxtn)) + + -- Advance time elapsed if in play state. + let cxtnp2 = cxtnp1 + let gsnp2 = gsnp1 & + if' (not . isPlaying $ gsnp1^.gsGameMode) + (id) + (gsTimeElapsed %~ (+ dt)) + + -- Respond to left and right mouse down by moving the camera. + rec + lastNetMouseRight <- delay 0 -< netMouseRight + netMouseRight <- returnA -< gsa^.gsaNetMouseRight + + lastIsPlayingState <- delay False -< isPlayingState + isPlayingState <- returnA -< isPlaying $ gsnp2^.gsGameMode + + foundChange <- hold False -< if' ((lastIsPlayingState == isPlayingState) && (lastNetMouseRight /= netMouseRight)) (Just True) Nothing + + let cameraAngleSpeed = 1.0 -- radians per second -- TODO: use neverballrc rotate_slow + let updateCameraAngle = if' (not foundChange || not isPlayingState) id $ + (gsCameraAngle %~ (+ (-fromIntegral netMouseRight) * cameraAngleSpeed * dt)) . + id + let gsnp3 = gsnp2 & updateCameraAngle + let cxtnp3 = cxtnp2 + + -- Physically expend dt to advance the ball's position by its velocity, + -- handling physics collisions. + (gsnp4, cxtnp4) <- returnAWithoutMiddle ||| stepGameBallPhysics -< if' (not isPlayingState) Left Right $ (gsnp3, dt, cxtnp3) + + -- Identify output. + let gs = gsnp4 + let cxt = cxtnp4 + + -- Return. + returnA -< (gs, cxt) + where + returnAWithoutMiddle = arr $ \(a, _b, c) -> (a, c) + +-- | Step the debug free camera. +-- +-- Check whether this mode is enabled before using this wire. +stepGameClockDebugFreeCamera :: Wire ImmutaballM (GameState, Double, IBStateContext) (GameState, IBStateContext) +stepGameClockDebugFreeCamera = proc (gsn, dt, cxtn) -> do + let gsa = mkGameStateAnalysis cxtn gsn + let netMov = gsa^.gsaNetRightForwardJump + let (netRight, netForward, netJump) = netMov + + -- FRP architecture note: we have access to both 1) local state (FRP) and + -- 2) the relatively global game state. If we wanted, we could use FRP to + -- make a wire (time-varying value) that outputs the free camera position + -- offset value, and just unconditionally set the game state, disregarding + -- its input. We could also instead not use FRP but just calculate the + -- next state. + -- + -- To demonstrate capabilities, I instead take a third, hybrid approach: + -- both. Use FRP to calculate a diff locally, and then apply that diff to + -- the state (relatively) globally. + + let (unrotatedNetMovementVec :: Vec3 Double) = Vec3 (fromIntegral netRight) (fromIntegral netForward) (fromIntegral netJump) + let (netMovementVec :: Vec3 Double) = tilt3ySimple (v3normalize $ (gsa^.gsaView.mviewTarget) `minusv3` (gsa^.gsaView.mviewPos)) `mv3` unrotatedNetMovementVec + -- relativeNetMovementVec is not needed: netMovementVec _already_ includes the free camera rotation, not just the original orientation in the level file. + --let (relativeNetMovementVec :: Vec3 Double) = aimVert3DSimple (Just $ 0.99*tau) (gsn^.gsDebugState.gdsCameraAimUpRadians) . aimHoriz3DSimple (gsn^.gsDebugState.gdsCameraAimRightRadians) $ netMovementVec + let netMovementVec' = if' (not freeCameraRelative) unrotatedNetMovementVec $ netMovementVec + posOffset <- integrate zv3 -< (dt * freeCameraSpeed) `sv3` netMovementVec' + + -- FRP (local). + posOffsetDiff <- differentiate -< posOffset + -- State (global). + let posOffsetUpdate = gsDebugState.gdsCameraPosOffset %~ (+ posOffsetDiff) + let gsnp1 = gsn & posOffsetUpdate + + -- Identity output. + let gs = gsnp1 + let cxt = cxtn + + -- Return. + returnA -< (gs, cxt) + + where + -- Units per second. + freeCameraSpeed :: Double + freeCameraSpeed = 2.0 + + -- Relative to aim? This is normal behavior, but temporarily setting + -- this to False is an option. + freeCameraRelative :: Bool + freeCameraRelative = True + +-- | Expend dt to step the ball through the physical world. +-- +-- Apply gravity and handle collisions. +stepGameBallPhysics :: Wire ImmutaballM (GameState, Double, IBStateContext) (GameState, IBStateContext) +stepGameBallPhysics = proc (gsn, dt, cxtn) -> do + let gsa = mkGameStateAnalysis cxtn gsn + + let x'cfg = cxtn^.ibContext.ibStaticConfig + + -- Find the gravity vector. + let gravityVectorUnrotated = (gsa^.gsaUpVec) & z3 %~ negate -- Mirror on xy plane. + let gravityVector = rotatexySimple (gsn^.gsCameraAngle) `mv3` gravityVectorUnrotated + -- Don't apply the gravity vector yet, since we might apply too much dt, + -- e.g. before the ball rests back on the floor; this could make the ball + -- bouncy, especially depending on the frame rate. + {- + let gravityAcceleration = x'cfg^.x'cfgGravity + let updateGravity = + (gsBallVel %~ (+ (dt * gravityAcceleration) `sv3` gravityVector)) . + id + let gsnp1 = gsn & updateGravity + -} + let gsnp1 = gsn + let cxtnp1 = cxtn + + -- Advance the ball through the physical world, handling collisions. + -- + -- Expend dt to apply its velocity to the position, handling collisions by + -- applying reflections. + let (ballPos', ballVel') = physicsBallAdvance x'cfg (gsnp1^.gsSol) (gsnp1^.gsSolAnalysis.saPhysicsAnalysis) (gsnp1^.gsSolAnalysis.saOtherAnalysis) (gsnp1^.gsBallRadius) gravityVector gsnp1 dt (gsnp1^.gsBallPos) (gsnp1^.gsBallVel) + let updateBall = + (gsBallPos .~ ballPos') . + (gsBallVel .~ ballVel') . + id + let (gsnp2, cxtnp2) = (gsnp1 & updateBall, cxtnp1) + + -- Identify output. + let gs = gsnp2 + let cxt = cxtnp2 + + -- Return. + returnA -< (gs, cxt) + +-- | Expend dt to step the ball through the physical world, handling collisions. +physicsBallAdvance :: StaticConfig -> LevelIB -> SolPhysicsAnalysis -> SolOtherAnalysis -> Double -> Vec3 Double -> GameState -> Double -> Vec3 Double -> Vec3 Double -> (Vec3 Double, Vec3 Double) +physicsBallAdvance = \x'cfg -> case (x'cfg^.x'cfgRequestAlternativePhysics) of + Nothing -> physicsBallAdvanceDefault x'cfg + Just "default" -> physicsBallAdvanceDefault x'cfg + Just "stationary" -> physicsBallAdvanceStationary x'cfg + Just "ghostly" -> physicsBallAdvanceGhostly x'cfg + Just "brute-force" -> physicsBallAdvanceBruteForce x'cfg + Just "bsp" -> physicsBallAdvanceBSP x'cfg + _ -> physicsBallAdvanceDefault x'cfg + +-- | Expend dt to step the ball through the physical world, handling collisions. +physicsBallAdvanceDefault :: StaticConfig -> LevelIB -> SolPhysicsAnalysis -> SolOtherAnalysis -> Double -> Vec3 Double -> GameState -> Double -> Vec3 Double -> Vec3 Double -> (Vec3 Double, Vec3 Double) +physicsBallAdvanceDefault x'cfg level spa soa ballRadius gravityVector gs dt ballPos ballVel = choice_ x'cfg level spa soa ballRadius gravityVector gs dt ballPos ballVel + where + choice_ :: StaticConfig -> LevelIB -> SolPhysicsAnalysis -> SolOtherAnalysis -> Double -> Vec3 Double -> GameState -> Double -> Vec3 Double -> Vec3 Double -> (Vec3 Double, Vec3 Double) + --choice_ = physicsBallAdvanceStationary + --choice_ = physicsBallAdvanceGhostly + --choice_ = physicsBallAdvanceBruteForce + choice_ = physicsBallAdvanceBSP + +-- | For debugging or performance checking, keep the ball stationary. +physicsBallAdvanceStationary :: StaticConfig -> LevelIB -> SolPhysicsAnalysis -> SolOtherAnalysis -> Double -> Vec3 Double -> GameState -> Double -> Vec3 Double -> Vec3 Double -> (Vec3 Double, Vec3 Double) +physicsBallAdvanceStationary _x'cfg _level _spa _soa _ballRadius _gravityVector _gs _dt p0 v0 = (p1, v0) + where + p1 = p0 + +-- | For debugging or performance checking, ignore all collision checking. +physicsBallAdvanceGhostly :: StaticConfig -> LevelIB -> SolPhysicsAnalysis -> SolOtherAnalysis -> Double -> Vec3 Double -> GameState -> Double -> Vec3 Double -> Vec3 Double -> (Vec3 Double, Vec3 Double) +physicsBallAdvanceGhostly x'cfg _level _spa _soa _ballRadius gravityVector _gs dt p0 v0 = (p1, v1) + where + p1 = p0 + (dt `sv3` v1) + v1 = v0 + ((dt * gravityAcceleration) `sv3` gravityVector) + gravityAcceleration = x'cfg^.x'cfgGravity + +-- | This version completely ignores the BSP. It checks collisions with every +-- lump every frame. +physicsBallAdvanceBruteForce :: StaticConfig -> LevelIB -> SolPhysicsAnalysis -> SolOtherAnalysis -> Double -> Vec3 Double -> GameState -> Double -> Vec3 Double -> Vec3 Double -> (Vec3 Double, Vec3 Double) +physicsBallAdvanceBruteForce = physicsBallAdvanceBruteForceCompute 0 0.0 0.0 + +-- | Finish computing 'physicsBallAdvanceBruteFroce'. +-- +-- Make a line segment from p0 to p1, where p1 is p0 + dt*v, i.e. the tentative +-- end-point of the ball's position after the frame, if no collisions occur. +-- Check all lumps for a closest collision, and if one is found, expend enough +-- dt to advance the ball to the point of intersection, and then reflect v0 +-- about the face's plane, and repeat, checking again for all lumps using the +-- remaining dt to expend. Since the path represent the center of the ball, +-- use the sphere's radius to check for distance. For edges and vertices, use +-- as the plane a constructed plane where the plane is orthogonal to the line +-- from the (new) ball center to the point of intersection. Once no collisions +-- have been detected, freely expend the remaining dt. We now have the new +-- ball position, at the last p1. +-- +-- Parameters: +-- +-- numCollisions: +-- for testing squishes, this is incremented each collision, and once it +-- exceeds the maximum, the squish condition is detected and the physics +-- engine will skip any remaining collisions, letting the ball go through lumps. +-- thresholdTimeRemaining: +-- Once this much dt has been expended, reset the 2 squish detection +-- parameters (this and numCollisions). +-- thresholdRDistanceRemaining: +-- Once the ball has traveled this much distance in terms of ball radiuses, +-- reset the squish state in this condition too. We don't want the ball the +-- ghost through walls if the frame is slow and processing a lot of dt at +-- once, simply because it made many collisions in a frame even though it +-- traveled a long distance (e.g. spinning around in a cone if the system +-- briefly pauses), so we have thresholdTimeRemaining; and we also have +-- distance because otherwise the ball can always go fast enough so that it +-- bounces enough times between lumps and ghosts through. +-- +-- TODO: I once observed a rare glitching through a wall on Medium 16. +-- Probably make the planes and collisions handling a little more rigorous to +-- fix it, but the brute force algorithm isn't designed to be the primary +-- physics algorithm, so it probably isn't very important. +physicsBallAdvanceBruteForceCompute :: Integer -> Double -> Double -> StaticConfig -> LevelIB -> SolPhysicsAnalysis -> SolOtherAnalysis -> Double -> Vec3 Double -> GameState -> Double -> Vec3 Double -> Vec3 Double -> (Vec3 Double, Vec3 Double) +--physicsBallAdvanceBruteForceCompute numCollisions thresholdTimeRemaining thresholdRDistanceRemaining x'cfg level spa _soa ballRadius gravityVector gs dt p0 v0 = +physicsBallAdvanceBruteForceCompute numCollisions thresholdTimeRemaining thresholdRDistanceRemaining x'cfg level spa soa ballRadius gravityVector gs dt p0 v0 + -- Redundantly ensure dt is not zero or negative. + | dt <= 0 + smallNum = let (p1, v1) = (p0, v0) in (p1, v1) + -- Check the optional maxPhysicsStepTime config. + | Just maxPhysicsStepTime <- x'cfg^.x'cfgMaxPhysicsStepTime, dt > maxPhysicsStepTime + smallNum = + let (p1, v1) = + physicsBallAdvanceBruteForceCompute + numCollisions + thresholdTimeRemaining + thresholdRDistanceRemaining + x'cfg + level + spa + soa + ballRadius + gravityVector + gs + maxPhysicsStepTime + p0 + v0 in + physicsBallAdvanceBruteForceCompute + numCollisions + thresholdTimeRemaining + thresholdRDistanceRemaining + x'cfg + level + spa + soa + ballRadius + gravityVector + gs + (dt - maxPhysicsStepTime) + p1 + v1 + -- Now step the physics. + | otherwise = + case closestLumpIntersecting of -- Find the next collision. + Nothing -> -- No more collisions this frame. + -- Gravity: apply gravity to the rest of the path. + let (p1, v1) = (p0 + (dt `sv3` v0), v0g dt) in (p1, v1) -- Expend the rest of dt after the last collision. + Just (_lastLi', edt, p0', v0') -> -- Found the next collision. Expend ‘edt’ to advance the pall to p0'. + -- Gravity: only apply the gravity vector through to the next collision, later on when we produce what is v0' here. + let travelRDistance = (p0' - p0)^.r3 / ballRadius; trd = travelRDistance in + physicsBallAdvanceBruteForceCompute + ( if' resetSquishState 0 (numCollisions + 1) ) + ( if' resetSquishState (x'cfg^.x'cfgMaxFrameCollisionsDtThreshold - edt) (thresholdTimeRemaining - edt) ) + ( if' resetSquishState (x'cfg^.x'cfgMaxFrameCollisionsRDistanceThreshold - edt) (thresholdRDistanceRemaining - trd) ) + x'cfg + level + spa + soa + ballRadius + gravityVector + gs + (dt - edt) + p0' + v0' + + where + bounceReturn = x'cfg^.x'cfgBounceReturn + gravityAcceleration = x'cfg^.x'cfgGravity + + resetSquishState + | thresholdTimeRemaining <= 0 = True + | thresholdRDistanceRemaining <= 0 = True + | otherwise = False + + -- | Find the closest lump intersecting the ball's path, for collisions. + closestLumpIntersectingRaw :: Maybe (Int32, Double, Vec3 Double, Vec3 Double) + --closestLumpIntersectingRaw = safeHead . sortOn (^._2) . catMaybes . toList $ lumpsIntersecting + closestLumpIntersectingRaw = safeHead . sortOn (^._2) . catMaybes $ lumpsIntersecting + + -- | Check cfgMaxFrameCollisions, and whether dt is already exhausted. + closestLumpIntersecting :: Maybe (Int32, Double, Vec3 Double, Vec3 Double) + closestLumpIntersecting + | numCollisions >= (x'cfg^.x'cfgMaxFrameCollisions) = Nothing + | dt <= 0 || (dt - 0) `equivalentSmall` 0 = Nothing + | otherwise = closestLumpIntersectingRaw + + -- | Map each lump into the closest collision, and get 1) the dt + -- needed to expend to advance the ball to this point of collision, 2) + -- the new ball pos and 3) ball vel. + -- + -- Only the closest collision will be used for advancing the ball, + -- before checking for collision again afterwards. + --lumpsIntersecting :: Array Int32 (Maybe (Double, Vec3 Double, Vec3 Double)) + --lumpsIntersecting = level^.solLv <&> \lump -> + lumpsIntersecting :: [Maybe (Int32, Double, Vec3 Double, Vec3 Double)] + lumpsIntersecting = flip fmap (zip [0..] (toList $ level^.solLv)) . uncurry $ \li lump -> + let + checkVertices :: Bool + -- I suspect checking the length of facesIntersectingNoBounds + -- can introduce a space leak (e.g. try out retour de force 2), + -- but it turns out probably checking the length of + -- edgesIntersecting is probably better anyway. + --checkVertices | (_:_:_:_) <- facesIntersectingNoBounds = True | otherwise = False + -- TODO FIXME: verify this also isn't broken, but for now just + -- always check verts. + --checkVertices | (_:_:_) <- edgesIntersecting = True | otherwise = False + checkVertices = True + verticesIntersecting :: [(Int32, Double, Vec3 Double, Vec3 Double)] + verticesIntersecting = if' (not checkVertices) [] $ do + -- For each verte, + vi <- indirection <$> [lump^.lumpV0 .. lump^.lumpV0 + lump^.lumpVc - 1] + let vertex = (level^.solVv) ! vi + let v = vertex^.vertP + + -- Find the distance between the path (lp) and the vertex. + let vd = abs $ line3PointDistance lp v + + -- Skip if the _infinite_ line extension from lp and + -- the vertex are too far away. This allows an early check + -- and also to ensure the call to line3DistanceCoordFromPoint is valid. + guard $ vd <= ballRadius + + -- Find the closest point coord on lp to the vertex. + let lpClosestX = line3PointCoord lp v + + -- Find how far away the candidates for x (where the ball + -- is exactly ballRadius away from the vertex) are from + -- closestX. + let lpCoordOffset = line3DistanceCoordFromPoint lp v ballRadius + + -- Find the coord on lp where the distance is the ball's + -- radius. Skip if we have nothing on lp. + let xCandidates = [lpClosestX - lpCoordOffset, lpClosestX + lpCoordOffset] + (x:_) <- return . sort . filter (\x -> 0 <= x + smallNum && x - smallNum <= 1) $ xCandidates + + -- Skip if x is not on lp. (Already done by the filter above.) + --guard $ 0 <= x + smallNum && x - smallNum <= 1 + + -- Find the ball intersection point. + let ballIntersection = line3Lerp lp x `v3orWith` (lp^.p0l3) + + -- For the reflecting plane for the ball's velocity, + -- construct a virtual plane essentially with the vector + -- from the vertex to the ball's position at intersection + -- as normal. + let virtualPlane = normalPlane3 (v3normalize $ ballIntersection - v) 0 + + -- Make sure the ball is going towards the vertex, not away + -- from it, similar to the normal check for planes for + -- avoiding multiple collisions in a single step for me + -- thasme lump. + guard $ (lp^.a0l3) `d3` (virtualPlane^.abcp3) <= 0 + + -- Return the results of this collision, which is used if + -- it is found to be the first potential collision on the + -- path lp. + let edt = x * dt + let p0' = ballIntersection + let v0' = plane3ReflectPointAmount (virtualPlane & dp3 .~ 0) (v0g edt) (bounceReturn) -- v0g: Apply gravity for this path. + return $ (li, edt, p0', v0') + + checkEdges :: Bool + -- TODO FIXME: length >= 2 seems to cause edge collision detection + -- to not work. For now just disable this check. + --checkEdges | (_:_:_) <- facesIntersectingNoBounds = True | otherwise = False + checkEdges = True + edgesIntersecting :: [(Int32, Double, Vec3 Double, Vec3 Double)] + edgesIntersecting = if' (not checkEdges) [] $ do + -- For each edge, + ei <- indirection <$> [lump^.lumpE0 .. lump^.lumpE0 + lump^.lumpEc - 1] + let edge = (level^.solEv) ! ei + let (vi, vj) = (((level^.solVv) ! (edge^.edgeVi))^.vertP, ((level^.solVv) ! (edge^.edgeVj))^.vertP) + let el = line3Points vi vj + + -- Find the distance between the path (lp) and the edge. + let ed = abs $ line3Line3Distance lp el + + -- Skip if _the infinite lines_ are too far away. However, + -- the line segments may still be too far away even if the + -- infinite lines are not, so we'll filter lp coords in [0, 1]. + guard $ ed <= ballRadius + + -- Find the closest point. + --Just (lpx, elx) <- return $ line3Line3ClosestCoords lp el + let (lpx, elx) = line3Line3ClosestCoordsAny lp el + let elv = line3Lerp el elx + + -- Find the point on lp where the ball is at when it first + -- collides with the edge. + let lpCoordOffset = abs $ line3DistanceCoordFromPoint lp elv ballRadius + + -- Find candidates for x: they must be within [0, 1]; if no + -- candidates pass, the line segment (the path) is too far + -- away from the edge, so we'll skip this edge. + let xCandidates = [lpx - lpCoordOffset, lpx + lpCoordOffset] + (x:_) <- return . sort . filter (\x -> 0 <= x + smallNum && x - smallNum <= 1) $ xCandidates + + let ballIntersection = line3Lerp lp x `v3orWith` (lp^.p0l3) + + let edgePointBallIntersection = line3Lerp el . line3PointCoord el $ ballIntersection + + -- Check to make sure the intersection is actually on the + -- edge _line segment_, not to leave it checking its + -- infinite line only! + let intersectionElx = line3PointCoord el edgePointBallIntersection + guard $ 0 <= intersectionElx + smallNum && intersectionElx - smallNum <= 1 + + -- For the reflecting plane for the ball's velocity, + -- construct a virtual plane essentially with the vector + -- from the edge to the ball's position at intersection as + -- normal. + let virtualPlane = normalPlane3 (v3normalize $ ballIntersection - edgePointBallIntersection) 0 + + -- Make sure the ball is going towards the edge, not away + -- from it, similar to the normal check for planes for + -- avoiding multiple collisions in a single step for the + -- same lump. + guard $ (lp^.a0l3) `d3` (virtualPlane^.abcp3) <= 0 + + -- Return the results of this collision, which is used if + -- it is found to be the first potential collision on the + -- path lp. + let edt = x * dt + let p0' = ballIntersection + let v0' = plane3ReflectPointAmount (virtualPlane & dp3 .~ 0) (v0g edt) (bounceReturn) -- v0g: Apply gravity for this path. + return $ (li, edt, p0', v0') + + -- | Find all faces that intersect p0->p1. + -- + -- Find where the p0->p1 intersects a side's plane. However, + -- handle the bounds of the face: if the face's plane's point + -- of intersection with p0->p1 is not behind (<=) all other + -- planes, then it's beyond the edges bordering the side. + -- + -- Note this requires that all sides have a normal pointing + -- _away_ from the convex lump inside the level file. + facesIntersecting :: [(Int32, Double, Vec3 Double, Vec3 Double)] + facesIntersecting = facesIntersecting' False + _facesIntersectingNoBounds :: [(Int32, Double, Vec3 Double, Vec3 Double)] + _facesIntersectingNoBounds = facesIntersecting' True + -- | We use ignoreEdgeBounds when checking for edge and vertex + -- intersections. + facesIntersecting' :: Bool -> [(Int32, Double, Vec3 Double, Vec3 Double)] + facesIntersecting' ignoreEdgeBounds = do + let errMsg = "Internal error: physicsBallAdvanceBruteForceCompute: sides data missing for lump with li " ++ (show li) ++ "." + let sidePlanes = flip M.lookup (spa^.spaLumpPlanes) li `morElse` error errMsg + + -- For each side (check useDirectSol for which set of sides to use), + (sidx, sidePlane) <- + if useDirectSol + then do + -- For each side, + si <- indirection <$> [lump^.lumpS0 .. lump^.lumpS0 + lump^.lumpSc - 1] + let side = (level^.solSv) ! si + -- Get its plane. + let sidePlane = normalPlane3 (side^.sideN) (side^.sideD) + return (si, sidePlane) + else do + (sidx, sidePlane) <- zip [0..] sidePlanes + return (sidx, sidePlane) + -- Find where on lp it intersects; abort this try if it doesn't. + Just x <- return $ line3CoordAtDistancePlane3 sidePlane lp ballRadius + -- Only consider intersections on the line segment. + --guard $ (0 <= x + smallNum && x - smallNum <= 1) + -- The right side prevents the ball from ghost-glitching + -- through a wall for very short 'lp' ('onPlaneCheck'). + let intersectsLp = 0 <= x + smallNum && x - smallNum <= 1 + let onPlaneCheck = plane3PointDistance sidePlane (lp^.p0l3) `near` ballRadius && plane3PointDistance sidePlane (lp^.p1l3) `near` ballRadius + guard $ intersectsLp || onPlaneCheck + + -- Get the point in 3D space: this is where the ball would + -- be if advanced to this intersection. + let ballIntersection = line3Lerp lp x `v3orWith` (lp^.p0l3) + -- Get the point on the plane where this collision would + -- take place: the closest point on the plane to + -- 'ballIntersection'. + let planeIntersection = pointToPlane ballIntersection sidePlane + -- Only consider intersections whose plane intersection + -- points are behind all other sides. + guard . (if' ignoreEdgeBounds (const True) id) . and $ do + if useDirectSol + then do + let si = sidx + + -- For every other side … + sj <- [lump^.lumpS0 .. lump^.lumpS0 + lump^.lumpSc - 1] + guard $ sj /= si + let sidej = (level^.solSv) ! sj + let sidejPlane = normalPlane3 (sidej^.sideN) (sidej^.sideD) + + -- Make sure the point is behind this plane. + return $ plane3PointDistance sidejPlane planeIntersection <= 0 + else do + -- For every other side … + (sjidx, sidejPlane) <- zip [0..] sidePlanes + guard $ sjidx /= sidx + + -- Make sure the point is behind this plane. + return $ plane3PointDistance sidejPlane planeIntersection <= 0 + + -- Finally, make sure we only register a collision if the + -- ball is going towards this plane, not away from it: e.g. + -- you can only collide against a top face from above, not + -- from underneath. This prevents the same lump causing + -- multiple collision events for what should be a single + -- collision. We can do this by making sure the dot + -- product of the direction (axis) of ‘lp’ and the plane + -- normal is not positive. + guard $ (lp^.a0l3) `d3` (sidePlane^.abcp3) <= 0 + + -- We've found an intersection. Now calculate the values + -- we would need if we ended up picking this after finding it + -- is indeed the closest. + + let edt = x * dt + let p0' = ballIntersection + let v0' = plane3ReflectPointAmount (sidePlane & dp3 .~ 0) (v0g edt) (bounceReturn) -- v0g: Apply gravity for this path. + return $ (li, edt, p0', v0') + + where + useDirectSol = False + + -- | Lower dimensionalities appear before higher + -- dimensionalities for equal distances. 'sortOn' is a stable + -- sort, so we can use it. + allIntersecting = concat $ + [ + verticesIntersecting, + edgesIntersecting, + facesIntersecting + ] + + sortedIntersecting = sortOn (^._2) $ allIntersecting + + lumpComponentIntersecting :: Maybe (Int32, Double, Vec3 Double, Vec3 Double) + lumpComponentIntersecting = safeHead sortedIntersecting + + -- Make sure the lump isn't the one we last used for collisions. + r = lumpComponentIntersecting + in + r + + where + -- | Draw a line segment from the ball's position (center of + -- sphere) to the tentative end-point if all dt were to be + -- expended now using its current velocity. + -- + -- TODO: double check edge cases of small lp don't cause + -- issues. The guard has a p0 and p1 nearness check, but there + -- might still be issues. + lp = let p1 = p0 + (dt `sv3` v0) in line3Points p0 p1 + + -- | It seems sols have indirection for lump sides, vertices, and + -- edges, but not edge indices to vertices. + indirection :: Int32 -> Int32 + indirection idx = (level^.solIv) ! idx + + v0g edt = v0 + ((edt * gravityAcceleration) `sv3` gravityVector) -- What velocity is if v0 has time added to gravity. + +-- | Advance the ball's position and velocity, using the level BSP to handle +-- collisions and gravity. +-- +-- Try expending the remaining dt, and detecting if any collisions are made +-- with any lumps or BSP partitions (e.g. check if the side (-1,0,1) of a plane +-- the position point is on would change). If there's a collision, then p0->p1 +-- intersects, and this algorithm sorts all the detected intersections to only +-- use the closest one, and then also checks among the remaining collisions the +-- ones that are near by the closest ones, to make sure these possible +-- collisions aren't skipped if advancing to the closest collision also changes +-- e.g. which side of a plane the ball would be on if it is advanced to the +-- closest collision. We expend dt to advance the ball to the closest +-- collision and also check immediate (or near) new collisions the same +-- distance away from the closest collision. Then we repeat the process anew +-- with the remaining dt to expend on advancing the ball, until there are no +-- more collisions, in which case we expend the remaining dt. +-- +-- Also add a squish check mechanism: only so many collisions are permitted +-- within a specific distance and for a specific amount of dt. If a squish +-- condition is detected, then instead of potentially looping forever (and +-- hanging), just abort collisions and let the ball ‘wall-glitch’ through walls +-- to move through them. +-- +-- TODO: support moving bodies, since this currently only checks current static +-- position. +-- +-- TODO: this is complete for stationary bodies but currently has a few bugs: +-- 1) It misses some edge collisions especially if the ball is resting and +-- falls off an edge (but can handle it correctly if they ball falls from a +-- distance onto the edge). (See commit log for more notes on some debugging +-- related to this.) To reproduce, make a simple single lump map with the +-- ball falling down onto it. Sometimes even falling it misses the edge +-- collision, but it always seems to fall through too early if the ball +-- rests first. +-- 2) FIXED: don't forget ballRadius when discarding BSP children. +-- 3) On Easy 3 (coins.sol), when the ball goes across an edge between the +-- lumps it starts on and in front of it, it can freeze for a second or two, +-- sometimes throwing the ball sort of randomly once it resumes. +-- 4) FIXED: ball no longer ghosts through certain lumps; the fix was the lump +-- plane construction deduplication threshold was too tight. +physicsBallAdvanceBSP :: StaticConfig -> LevelIB -> SolPhysicsAnalysis -> SolOtherAnalysis -> Double -> Vec3 Double -> GameState -> Double -> Vec3 Double -> Vec3 Double -> (Vec3 Double, Vec3 Double) +physicsBallAdvanceBSP x'cfg level spa soa ballRadius gravityVector gs dt p0 v0 + | Just maxPhysicsStepTime <- x'cfg^.x'cfgMaxPhysicsStepTime, dt > maxPhysicsStepTime = + let (p1, v1) = advance 0 0.0 0.0 maxPhysicsStepTime p0 v0 + in (physicsBallAdvanceBSP x'cfg level spa soa ballRadius gravityVector gs) (dt - maxPhysicsStepTime) p1 v1 + | otherwise = + advance 0 0.0 0.0 dt p0 v0 + + where + bounceReturn = x'cfg^.x'cfgBounceReturn + gravityAcceleration = x'cfg^.x'cfgGravity + + -- | It seems sols have indirection for lump sides, vertices, and + -- edges, but not edge indices to vertices. + indirection :: Int32 -> Int32 + indirection idx = (level^.solIv) ! idx + + -- Descend each BSP to find the closest intersecting lump, collecting + -- all other lumps within threshold distance from the closest + -- insersection and then checking them (avoiding a wall-glitch) before + -- proceeding. + -- + -- Repeat until all remaining dt is expended, or a squish condition is + -- detected. + advance :: Integer -> Double -> Double -> Double -> Vec3 Double -> Vec3 Double -> (Vec3 Double, Vec3 Double) + advance numLocalCollisions localDtExpended localDistance dtn pn vn + | localDtExpended >= (x'cfg^.x'cfgMaxFrameCollisionsDtThreshold) = advance 0 0.0 0.0 dtn pn vn + | localDistance >= (x'cfg^.x'cfgMaxFrameCollisionsRDistanceThreshold) = advance 0 0.0 0.0 dtn pn vn + | numLocalCollisions >= (x'cfg^.x'cfgMaxFrameCollisions) = (p1, v1) + | dt <= 0 = (p1, v1) + | otherwise = result + where + -- | Tentative end-point: advance here if no collisions. + p1 :: Vec3 Double + p1 = pn + (dtn `sv3` vn) + + -- | Tentative end-point velocity: used if no collisions. + v1 :: Vec3 Double + v1 = vng dtn + + -- | What velocity is if vn has time added to gravity. + vng edt = vg vn edt + vg v edt = v + ((edt * gravityAcceleration) `sv3` gravityVector) + + -- | Draw a line segment from the ball's position (center of + -- sphere) to the tentative end-point if all dt were to be + -- expended now using its current velocity. + _lp :: Line3 Double + _lp = line3Points p0 p1 + + -- | Take a position/point, and the given body by index, and + -- convert the position/coords to be in terms of the body frame + -- of reference, so that you can use vertices in the body that + -- could be moving on a path directly. Return to world coords + -- with 'ipb' afterwards. + pb :: Vec3 Double -> Int32 -> Vec3 Double + pb p bi = + let bodyTranslation = getBodyTranslation level soa gs bi 0 in + p - bodyTranslation + + ipb :: Vec3 Double -> Int32 -> Vec3 Double + ipb p bi = + let bodyTranslation = getBodyTranslation level soa gs bi 0 in + p + bodyTranslation + + -- | Lump, collection of lumps to check, distance to closest, + -- time required to expend to closest. + nextCollision :: Maybe NextCollision + nextCollision = + let addNothing (a, b) = (a, b, Nothing) in + (^.ncsNc) . flip execState (NextCollisionState Nothing ((addNothing . second ((^.lumpBSP)) <$>) . M.toList $ spa^.spaBodyBSPs)) . fix $ \me -> do + bspsLeft <- gets (^.ncsBspsLeft) + case bspsLeft of + [] -> return () + ((bi, bsp, mbspParent):bspsLeft') -> do + modify (ncsBspsLeft .~ bspsLeft') + + let p0' = pb p0 bi + let p1' = pb p1 bi + let lp' = line3Points p0' p1' + + -- We now have a current best distance. If this + -- BSP partition, including all lumps directly on + -- it, is entirely further away, we can skip it! + mcurrentBestDistance <- gets (((^.ncDistanceTo) <$>) . (^.ncsNc)) + let mdistanceToParentPlane = do + bspParent <- mbspParent + let parentPlane = bspParent^.lbspppParent.lbsppPlane + _currentBestDistance <- mcurrentBestDistance + if' ((lp'^.a0l3.r3) <= smallishInfiniteLineThreshold) + (return $ plane3PointDistance parentPlane p0') + $ do + distanceInFront <- (/ (lp'^.a0l3.r3)) <$> line3CoordAtDistancePlane3 parentPlane lp' ballRadius + distanceBehind <- (/ (lp'^.a0l3.r3)) <$> line3CoordAtDistancePlane3 parentPlane lp' (-ballRadius) + return $ min distanceInFront distanceBehind + let canSkipThisBSP = (== Just True) $ do + currentBestDistance <- mcurrentBestDistance + distanceToParentPlane <- mdistanceToParentPlane + return $ distanceToParentPlane > currentBestDistance + if' canSkipThisBSP me $ do + + let withEmpty _then = do + me + let withLeaf bspPartition then_ = do + then_ bspPartition + let withFork l bspPartition r then_ = do + -- Try to eliminate l and r if we can show + -- there won't be a collision on that side of + -- the partition, then queue them up for + -- processing. + let queueL = + (plane3PointDistance (bspPartition^.lbsppPlane) p0') - ballRadius <= 0 || + (plane3PointDistance (bspPartition^.lbsppPlane) p1') - ballRadius <= 0 + let queueR = + (plane3PointDistance (bspPartition^.lbsppPlane) p0') + ballRadius >= 0 || + (plane3PointDistance (bspPartition^.lbsppPlane) p1') + ballRadius >= 0 + let newParent isRightBranch = LumpBSPPartitionParent { + _lbspppParent = bspPartition, + _lbspppIsRightBranch = isRightBranch + } + when queueL $ do + modify (ncsBspsLeft %~ ((bi, l, Just $ newParent False):)) + when queueR $ do + modify (ncsBspsLeft %~ ((bi, r, Just $ newParent True):)) + then_ bspPartition + deconsLabeledBinTree withEmpty withLeaf withFork bsp $ \bspPartition -> do + -- Check each lump directly intersecting this + -- BSP partition for a possible collision. + let (lumpsi :: S.Set Int32) = bspPartition^.lbsppLumps + (>> me) . forM_ lumpsi $ \lumpi -> do + let lump = (level^.solLv) ! lumpi + -- For now, we don't know all the details + -- of the collision while we collect the + -- closest and candidate other close lumps. + -- Check each plane for a collision, and + -- take the closest. We detect a collision + -- when lp' intersects with a lump's plane + -- at a point behind all the other planes. + + -- Skip this lump if it's detail flag is + -- set, which indicates it's only for + -- rendering and not part of the physical + -- world. + if' (((lump^.lumpFl) .&. lumpFlagDetail) /= 0) (return ()) $ do + + -- | Assume sorted and non-empty lists + let unsafeHead xs = case xs of (x:_) -> x; _ -> error "Internal error: physicsBallAdvanceBSP: unsafeHead called on empty list." + let nclDist ncl = unsafeHead (ncl^.nclLpPlaneIntersections) ^. lpxc.llpciDistance + let nclPrio ncl = unsafeHead (ncl^.nclLpPlaneIntersections) ^. lpxc.llpciPriority + -- | Discard all collisions not close to the nearest. + -- Also discard all collisions that diminish + -- priority within the same lump. + let (filterChecks :: NextCollisionLump -> [NextCollisionLump] -> [NextCollisionLump]) = \best checks -> + flip filter checks $ \candidate -> + -- Make sure it's close enough to best. + (nclDist candidate) - (nclDist best) <= smallishNum && + -- Make sure it's not priority + -- diminishing (increasing) within the + -- same lump, unless the distance + -- is significantly better. + (not + ((candidate^.nclLumpi) == (best^.nclLumpi)) && + (nclPrio candidate > nclPrio best) && + (nclDist candidate - smallishNum >= nclDist best) + ) + -- | Get this lump's planes. + let (lumpPlanes :: [Plane3 Double]) = M.lookup lumpi (spa^.spaLumpPlanes) `morElse` + (error $ "Internal error: physicsBallAdvanceBSP: nextCollision: failed to find planes for lump " ++ show lumpi ++ ".") + -- Query the current best and checks. + mnc <- gets (^.ncsNc) + let mncBest = (^.ncClosestLump) <$> mnc + let mncChecks = (^.ncCheckLumps) <$> mnc + let _mncFilterChecks = (pure filterChecks <*> mncBest) `morElse` id + -- | Get this plane's face intersections with lp'. + -- Also add a state layer that performs a + -- simple preliminary test to see if we need + -- to check for edge and vertex collisions. + let (lpFaceIntersectionsRaw :: [LumpLpPlaneFaceIntersection], needCheckEdgeVertCol :: Bool) = + flip runState False . runListT $ do + -- Get each plane and a list of all + -- other planes for this lump. + (planeIdx, (plane, others)) <- liftList $ zip [0..] $ listOthers lumpPlanes + + {- + -- Make sure we only register a collision if the + -- ball is going towards this plane, not away from it: e.g. + -- you can only collide against a top face from above, not + -- from underneath. This prevents the same lump causing + -- multiple collision events for what should be a single + -- collision. We can do this by making sure the dot + -- product of the direction (axis) of ‘lp’ and the plane + -- normal is not positive. + guard $ (lp'^.a0l3) `d3` (plane^.abcp3) <= 0 + -} + + -- To register a collision, make sure + -- the advancement would bring the ball + -- behind the plane: either p0 is + -- outside (plane distance > 1) going + -- in (== 0 || == 1), or p0 is + -- strictly intersecting (== 0) going + -- in (== -1). + -- Note: for edges and + -- vertices, there is more than 1 plane + -- attached to the edge, and in this + -- case lp' needs to be going + -- not-outside the plane for at least 1 + -- of the attach planes, not all. But + -- since we check each plane, for an + -- edge collision, there is still at + -- least 1 plane that will pass this + -- test, so we don't need to modify it for + -- edges and vertices. + guard $ signum (plane3PointDistance plane p1' - ballRadius - smallishNum) < signum (plane3PointDistance plane p0' - ballRadius + smallishNum) + + -- See if we need to use special logic + -- for very small steps. If so, we'll + -- focus more on just p0' without p1'. + let approximatelyAPoint = (lp'^.a0l3.r3) <= smallishInfiniteLineThreshold + + -- Find the coord on lp' at which we + -- find the intersection. + let intersectionCoord + | approximatelyAPoint = 0.0 + | otherwise = line3CoordAtDistancePlane3 plane lp' ballRadius `morElse` 0.0 + let intersectionBallPoint = line3Lerp lp' intersectionCoord + let intersectionPoint + | approximatelyAPoint = pointToPlane p0' plane + | otherwise = line3Lerp lp' $ intersectionCoord + ballRadius/(lp'^.a0l3.r3) + -- Find the distance from p0' across lp' + -- (or shortest line) to the plane + -- (where with ballRadius there is an + -- intersection). i.e. distance ball + -- would travel to reach the collision. + let distance + | approximatelyAPoint = plane3PointDistance plane p0' + | otherwise = (intersectionBallPoint - p0')^.r3 + -- Find the time to reach intersectionCoord. + let timeTo = (dtn * intersectionCoord) `florWith` 0.0 + + -- Now, make sure the intersection + -- point is on the lump, and not + -- outside the lump on some arbitrary + -- plane, since we have more data to + -- work with now. Also we do our + -- preliminary check for edge and + -- vertex collision detection here. + let (behindOthers, needCheck) = split $ + [ + r | + other <- others, + let d = plane3PointDistance other intersectionPoint, + let behind = d <= 0, + -- Also do preliminary + -- check for vertex and edge + -- collision. + let medgeLine = plane3Plane3 plane other, + let + foundNeedCheck Nothing = False + foundNeedCheck (Just edgeLine) + | behind = False + | line3PointDistance edgeLine p0' <= ballRadius = True + | line3PointDistance edgeLine p1' <= ballRadius = True + -- Note: line3Line3Distance checks the _infinite_ + -- line distance, so we still need to test more + -- precisely, but we at least shouldn't miss + -- edge or vert collisions. + | line3Line3Distance edgeLine lp' <= ballRadius = True + | otherwise = False, + let r = (behind, foundNeedCheck medgeLine) + ] + -- See if we need to check for + -- edges and vertices. + let behindAllOthers = and behindOthers + when (not behindAllOthers) $ do + alreadyTested <- lift $ get + when (not alreadyTested) $ do + let anyFoundNeedCheck = or needCheck + when anyFoundNeedCheck $ do + lift $ put True + -- Now skip if we're not behind all others. + -- (We should skip on edge and + -- vertex collisions if I'm not + -- mistaken, but in such cases + -- we'll still check later for edge + -- and vertex collisions. + guard $ behindAllOthers + + -- Construct the result. + return . fix $ \_lpLumpX -> LumpLpPlaneFaceIntersection { + _llpfiPlaneIdx = planeIdx, + _llpfiPlane = plane, + _llpfiDistance = distance, + _llpfiTimeTo = timeTo, + + _llpfiLi = lumpi, + _llpfiBi = bi, + _llpfiBodyTranslation = getBodyTranslation level soa gs bi 0, + + _llpfiLp = lp', + _llpfiIntersection = intersectionPoint, + + _llpfiIntersectionLx = intersectionCoord, + _llpfiIntersectionBall = intersectionBallPoint + } + -- Quick test: skip if no face + -- intersections and no need to check for + -- edge or vertex collisions. + if' (null lpFaceIntersectionsRaw && not needCheckEdgeVertCol) (return ()) $ do + + -- Check for edge and vertex collisions. + let (lpEdgeVertIntersectionsRaw :: [LumpLpPlaneIntersection]) + | not needCheckEdgeVertCol = [] + | otherwise = + let (edgeIntersections :: [LumpLpPlaneEdgeIntersection]) = do + -- For each edge on the lump, + ei <- indirection <$> [lump^.lumpE0 .. lump^.lumpE0 + lump^.lumpEc - 1] + let edge = (level^.solEv) ! ei + let (vi, vj) = (((level^.solVv) ! (edge^.edgeVi))^.vertP, ((level^.solVv) ! (edge^.edgeVj))^.vertP) + let el = line3Points vi vj + + -- Find the distance between the path (lp) and the edge. + let ed = abs $ line3Line3Distance lp' el + + -- Skip if _the infinite lines_ are too far away. However, + -- the line segments may still be too far away even if the + -- infinite lines are not, so we'll filter lp' coords in [0, 1]. + guard $ ed <= ballRadius + + -- Find the closest point. + --Just (lpx, elx) <- return $ line3Line3ClosestCoords lp el + let (lpx, elx) = line3Line3ClosestCoordsAny lp' el + let elv = line3Lerp el elx + + -- Find the point on lp where the ball is at when it first + -- collides with the edge. + let lpCoordOffset = abs $ line3DistanceCoordFromPoint lp' elv ballRadius + + -- Find candidates for x: they must be within [0, 1]; if no + -- candidates pass, the line segment (the path) is too far + -- away from the edge, so we'll skip this edge. + let xCandidates = [lpx - lpCoordOffset, lpx + lpCoordOffset] + (x:_) <- return . sort . filter (\x -> 0 <= x + smallNum && x - smallNum <= 1) $ xCandidates + + let ballIntersection = line3Lerp lp' x `v3orWith` (lp'^.p0l3) + + let edgePointBallIntersection = line3Lerp el . line3PointCoord el $ ballIntersection + + -- Check to make sure the intersection is actually on the + -- edge _line segment_, not to leave it checking its + -- infinite line only! + let intersectionElx = line3PointCoord el edgePointBallIntersection + guard $ 0 <= intersectionElx + smallNum && intersectionElx - smallNum <= 1 + + -- For the reflecting plane for the ball's velocity, + -- construct a virtual plane essentially with the vector + -- from the edge to the ball's position at intersection as + -- normal. + let virtualPlane = normalPlane3 (v3normalize $ ballIntersection - edgePointBallIntersection) 0 + + -- Make sure the ball is going towards the edge, not away + -- from it, similar to the normal check for planes for + -- avoiding multiple collisions in a single step for the + -- same lump. + guard $ (lp'^.a0l3) `d3` (virtualPlane^.abcp3) <= 0 + + -- Obtain some preliminary + -- results of this collision, + -- which is used if it is found + -- to be the first potential + -- collision on the path lp'. + let colEdt = x * dt + let distance = (ballIntersection - p0')^.r3 + + -- Return the result of this + -- collision candidate. + return $ LumpLpPlaneEdgeIntersection { + _llpeiDistance = distance, + _llpeiTimeTo = colEdt, + + _llpeiLi = lumpi, + _llpeiBi = bi, + _llpeiBodyTranslation = getBodyTranslation level soa gs bi 0, + + _llpeiLp = lp', + _llpeiIntersection = edgePointBallIntersection, + + _llpeiIntersectionLx = x, + _llpeiIntersectionBall = ballIntersection, + + _llpeiVirtualPlane = virtualPlane + } in + let (vertIntersections :: [LumpLpPlaneVertIntersection]) = do + -- For each vertex, + vi <- indirection <$> [lump^.lumpV0 .. lump^.lumpV0 + lump^.lumpVc - 1] + let vertex = (level^.solVv) ! vi + let v = vertex^.vertP + + -- Find the distance between the path (lp) and the vertex. + let vd = abs $ line3PointDistance lp' v + + -- Skip if the _infinite_ line extension from lp and + -- the vertex are too far away. This allows an early check + -- and also to ensure the call to line3DistanceCoordFromPoint is valid. + guard $ vd <= ballRadius + + -- Find the closest point coord on lp to the vertex. + let lpClosestX = line3PointCoord lp' v + + -- Find how far away the candidates for x (where the ball + -- is exactly ballRadius away from the vertex) are from + -- closestX. + let lpCoordOffset = line3DistanceCoordFromPoint lp' v ballRadius + + -- Find the coord on lp where the distance is the ball's + -- radius. Skip if we have nothing on lp. + let xCandidates = [lpClosestX - lpCoordOffset, lpClosestX + lpCoordOffset] + (x:_) <- return . sort . filter (\x -> 0 <= x + smallNum && x - smallNum <= 1) $ xCandidates + + -- Skip if x is not on lp. (Already done by the filter above.) + --guard $ 0 <= x + smallNum && x - smallNum <= 1 + + -- Find the ball intersection point. + let ballIntersection = line3Lerp lp' x `v3orWith` (lp'^.p0l3) + + -- For the reflecting plane for the ball's velocity, + -- construct a virtual plane essentially with the vector + -- from the vertex to the ball's position at intersection + -- as normal. + let virtualPlane = normalPlane3 (v3normalize $ ballIntersection - v) 0 + + -- Make sure the ball is going towards the vertex, not away + -- from it, similar to the normal check for planes for + -- avoiding multiple collisions in a single step for me + -- thasme lump. + guard $ (lp'^.a0l3) `d3` (virtualPlane^.abcp3) <= 0 + + -- Obtain some preliminary results of this collision, + -- which is used if it is found to be the first potential + -- collision on the path lp'. + let colEdt = x * dt + let distance = (ballIntersection - p0')^.r3 + + -- Return the result of this collision candidate. + return $ LumpLpPlaneVertIntersection { + _llpviDistance = distance, + _llpviTimeTo = colEdt, + + _llpviLi = lumpi, + _llpviBi = bi, + _llpviBodyTranslation = getBodyTranslation level soa gs bi 0, + + _llpviLp = lp', + _llpviIntersection = v, + + _llpviIntersectionLx = x, + _llpviIntersectionBall = ballIntersection, + + _llpviVirtualPlane = virtualPlane + } in + fmap VertIntersection vertIntersections ++ fmap EdgeIntersection edgeIntersections + + -- Aggregate all collisions. + let lpIntersectionsRaw = fmap FaceIntersection lpFaceIntersectionsRaw ++ lpEdgeVertIntersectionsRaw + + -- Sort all collisions. + let lpIntersectionsUnfiltered = sortBy lpxcomp lpIntersectionsRaw + + -- | If there are any intersections, see if + -- the best intersection is better than our + -- current best. (Otherwise we're done + -- with this lump.) + if' (null lpIntersectionsUnfiltered) (return ()) $ do + + -- We found at least one intersection. + + -- We'll only need the closest intersection on + -- this lump, and intersections close + -- enough within a smallishNum threshold to + -- test for edge and vertex collisions + -- later. + let lpIntersectionsFiltered = case lpIntersectionsUnfiltered of + [] -> [] -- (Should never happen.) + (closest:rest) -> closest : + let closestDist = closest^.lpxc.llpciDistance in + filter (\inters -> (inters^.lpxc.llpciDistance) - closestDist <= smallishNum) rest + let lpIntersections = lpIntersectionsFiltered + + -- Get the new best and new checks. + let (lumpNc :: NextCollisionLump) = NextCollisionLump lumpi lpIntersections + let (newBest, newChecksRaw) + | Just oldBest <- mncBest, Just oldChecks <- mncChecks = + if' (lumpNc `nclcomp` oldBest == LT) (lumpNc, oldBest:oldChecks) (oldBest, lumpNc:oldChecks) + | otherwise = (lumpNc, []) + let newChecks = filterChecks newBest newChecksRaw + + -- | Update the next collision state. + modify $ ncsNc .~ Just NextCollision { + _ncClosestLump = newBest, + _ncCheckLumps = newChecks, + _ncDistanceTo = nclDist newBest, + _ncTimeTo = unsafeHead (newBest^.nclLpPlaneIntersections) ^. lpxc.llpciTimeTo + } + + -- Now handle nextCollision and check checkLumps. + + -- | After the next collision, find (pn, vn, edt), position, + -- velocity, and dt expended. After we handle this + -- collision step, then we apply gravity based on the time + -- expended to travel this distance, and continue looping + -- through advance until we exhaust all collisions or reach a + -- squish condition. + afterNextCollision :: Maybe (Vec3 Double, Vec3 Double, Double) + afterNextCollision = (<$> nextCollision) $ \nc -> + let ourFlatten ((a, b), c) = (a, b, c) in + ourFlatten (foldl' step (pn, vn) $ (nc^.ncClosestLump) : (nc^.ncCheckLumps), nc^.ncTimeTo) + where + step :: (Vec3 Double, Vec3 Double) -> NextCollisionLump -> (Vec3 Double, Vec3 Double) + step (p, v) ncl + -- 3 possible collision types: vertex, edge, or + -- plane. The type depends on how many + -- intersections there are within threshold + -- distance to the closest. If there's only one + -- planar intersection, it's a plane; if 2, it's an + -- edge; if 3 or more, it's a vertex. + | [] <- ncl^.nclLpPlaneIntersections = + -- Redundant; internally should never happen. + (p, v) + -- | ((FaceIntersection px):[]) <- ncl^.nclLpPlaneIntersections = + | ((FaceIntersection px):_) <- ncl^.nclLpPlaneIntersections = + -- Just a single planar intersection. So + -- advance p, and mirror velocity about the + -- plane. + -- + -- TODO: handle body velocity! This for + -- now just assumes the body is stationary. + let plane = (px^.llpfiPlane) in + -- If the velocity is going away from the + -- plane due to a previous collision update + -- in this step (i.e. we're on a check + -- lump, not the first step), then skip. + if' (not $ v `d3` (plane^.abcp3) <= 0) (p, v) $ + let p' = ipb (px^.llpfiIntersectionBall) (px^.llpfiBi) in + let v' = plane3ReflectPointAmount (plane & dp3 .~ 0) v bounceReturn in + (p', v') + | ((EdgeIntersection px):_) <- ncl^.nclLpPlaneIntersections = + -- An edge intersection. + let plane = (px^.llpeiVirtualPlane) in + if' (not $ v `d3` (plane^.abcp3) <= 0) (p, v) $ + let p' = ipb (px^.llpeiIntersectionBall) (px^.llpeiBi) in + let v' = plane3ReflectPointAmount (plane & dp3 .~ 0) v bounceReturn in + (p', v') + | ((VertIntersection px):_) <- ncl^.nclLpPlaneIntersections = + -- An edge intersection. + let plane = (px^.llpviVirtualPlane) in + if' (not $ v `d3` (plane^.abcp3) <= 0) (p, v) $ + let p' = ipb (px^.llpviIntersectionBall) (px^.llpviBi) in + let v' = plane3ReflectPointAmount (plane & dp3 .~ 0) v bounceReturn in + (p', v') + + -- | Now apply gravity after advancing to the next collision. + afterNextCollisionGravity :: Maybe (Vec3 Double, Vec3 Double, Double) + afterNextCollisionGravity = (<$> afterNextCollision) $ \(pn', vn', edt) -> + (pn', vg vn' $ edt, edt) + + -- | The result of 'advance'. Try checking for collisions + -- again if we found a collision, else we can finish. + result :: (Vec3 Double, Vec3 Double) + result + | Just (pn', vn', edt) <- afterNextCollisionGravity = + advance + (numLocalCollisions + 1) + (localDtExpended + edt) + (localDistance + (pn' - pn)^.r3) + (dtn - edt) + pn' + vn' + | otherwise = + (p1, v1) + +-- * Utils. + +-- | Given the current game state, and the given _path_ by index (not body +-- index), get the translation of the path you can add body vertices to to get +-- the coords in world coords. +getPathTranslation :: LevelIB -> SolOtherAnalysis -> GameState -> Int32 -> Integer -> Vec3 Double +getPathTranslation _level soa gs pi_ derivativeDegree = + let translAtTime = M.lookup pi_ ((soa^.soaPathTranslationAtTime.fakeEOS) derivativeDegree) `morElse` + --(error $ "Error: getPathTranslation: failed to find translation map for path " ++ show pi_ ++ ".") + const zv3 in + -- TODO: Implement updating pathsTimeElapsed when stepping, then invert the comments in the next 2 lines. + let pathTimeElapsed = gs^.gsTimeElapsed in + --let pathTimeElapsed = flip M.lookup (gs^.gsPathState.psPathsTimeElapsed) pi_ `morElse` 0.0 in + let bodyTranslation = translAtTime pathTimeElapsed in + bodyTranslation + +-- | Given the current game state, and the given _body_ by index (not path +-- index), get the translation of the path you can add body vertices to to get +-- the coords in words coords. +getBodyTranslation :: LevelIB -> SolOtherAnalysis -> GameState -> Int32 -> Integer -> Vec3 Double +getBodyTranslation level soa gs bi derivativeDegree = + let body = (level^.solBv) ! bi in + let bodyPath = body^.bodyP0 in + let bodyTranslation = getPathTranslation level soa gs bodyPath derivativeDegree in + bodyTranslation -- * Local utils. diff --git a/Immutaball/Ball/State/Play.hs b/Immutaball/Ball/State/Play.hs --- a/Immutaball/Ball/State/Play.hs +++ b/Immutaball/Ball/State/Play.hs @@ -28,6 +28,7 @@ import qualified SDL.Raw.Enum as Raw import Immutaball.Ball.Game +import Immutaball.Ball.Level import Immutaball.Ball.LevelSets import Immutaball.Ball.State.Game import Immutaball.Share.Context @@ -78,7 +79,7 @@ let (mview :: MView) = gameStateAnalysis^.gsaView isPaint <- returnA -< ((const False) ||| (const True)) . matching (_Paint) $ request cxtnp2 <- returnA ||| renderLevel -< if' (not isPaint) (Left cxtnp1) (Right $ ((mview, (gameState^.gsSwa), gameState), cxtnp1)) - cxtnp3 <- returnA ||| renderBall -< if' (not isPaint) (Left cxtnp1) (Right $ (gameState, cxtnp2)) + cxtnp3 <- returnA ||| renderBall -< if' (not isPaint) (Left cxtnp1) (Right $ ((mview, gameState), cxtnp2)) -- GUI. Positioned after scene rendering. --(_guiResponse, cxtnp4) <- mkGUI playGui -< (GUIDrive request, cxtnp3) diff --git a/Immutaball/Putt/CLI.hs b/Immutaball/Putt/CLI.hs --- a/Immutaball/Putt/CLI.hs +++ b/Immutaball/Putt/CLI.hs @@ -143,7 +143,7 @@ ] immutaballVersion :: String -immutaballVersion = "0.1.0.4.1-hackage" +immutaballVersion = "0.1.0.5.1-hackage" -- | Run immutaball. immutaballWithCLIConfig :: StaticConfig -> CLIConfig -> ImmutaballIO diff --git a/Immutaball/Share/Config.hs b/Immutaball/Share/Config.hs --- a/Immutaball/Share/Config.hs +++ b/Immutaball/Share/Config.hs @@ -23,6 +23,7 @@ x'cfgGravity, x'cfgBounceReturn, x'cfgMaxFrameCollisions, x'cfgMaxFrameCollisionsDtThreshold, x'cfgMaxFrameCollisionsRDistanceThreshold, x'cfgMaxPhysicsStepTime, + x'cfgRequestAlternativePhysics, defaultStaticConfig, Neverballrc, Config(..), fullscreen, display, width, height, stereo, camera, @@ -162,7 +163,10 @@ -- gravity at once, sending it flying. Already the ball is bouncy even -- with this, however, so TODO: improve the physics to fix the bouncy -- elevator/gravity problem. - _x'cfgMaxPhysicsStepTime :: Maybe Double + _x'cfgMaxPhysicsStepTime :: Maybe Double, + + -- | Allow runtime configuration of the choice of physics engine. + _x'cfgRequestAlternativePhysics :: Maybe String } makeLenses ''StaticConfig' @@ -226,7 +230,9 @@ --_x'cfgMaxPhysicsStepTime = Just 0.01 -- Smooths out the gravity bounce issue, but larger levels can't handle it. --_x'cfgMaxPhysicsStepTime = Just 0.2 -- More tolerant, but e.g. retour de force for me would only handle this (or even Nothing) if I -- -- disabled edge and vertices by commenting out the 2 lines in the concat list. - _x'cfgMaxPhysicsStepTime = Just 0.02 + _x'cfgMaxPhysicsStepTime = Just 0.02, + + _x'cfgRequestAlternativePhysics = Nothing } type Neverballrc = Config diff --git a/Immutaball/Share/Level.hs b/Immutaball/Share/Level.hs --- a/Immutaball/Share/Level.hs +++ b/Immutaball/Share/Level.hs @@ -9,7 +9,6 @@ module Immutaball.Share.Level ( module Immutaball.Share.Level.Base, - module Immutaball.Share.Level.Render, module Immutaball.Share.Level.Parser, module Immutaball.Share.Level.Utils ) where @@ -18,6 +17,5 @@ --import Immutaball.Prelude import Immutaball.Share.Level.Base -import Immutaball.Share.Level.Render import Immutaball.Share.Level.Parser import Immutaball.Share.Level.Utils diff --git a/Immutaball/Share/Level/Analysis.hs b/Immutaball/Share/Level/Analysis.hs --- a/Immutaball/Share/Level/Analysis.hs +++ b/Immutaball/Share/Level/Analysis.hs @@ -15,7 +15,7 @@ module Immutaball.Share.Level.Analysis ( SolWithAnalysis(..), swaSol, swaSa, swaMeta, - SolAnalysis(..), saRenderAnalysis, saPhysicsAnalysis, + SolAnalysis(..), saRenderAnalysis, saPhysicsAnalysis, saOtherAnalysis, SolMeta(..), smPath, smLevelSet, sar, sap, SolRenderAnalysis(..), sraVertexData, sraVertexDataGPU, sraGeomData, @@ -32,14 +32,22 @@ sraGeomPassBis, sraGeomPassBisGPU, sraTexcoordsDoubleData, sraTexcoordsDoubleDataGPU, GeomPass(..), gpBi, gpMv, gpTextures, gpTexturesGPU, gpGis, gpGisGPU, + LumpBSP(..), lumpBSP, + LumpBSPPartition(..), lbsppPlane, lbsppLumps, lbsppLumpsMeanVertex, + lbsppAllLumps, lbsppAllLumpsMeanVertex, SolPhysicsAnalysis(..), spaLumpOutwardsSides, spaLumpOutwardsSidesNumNegatedNormals, spaLumpOutwardsSidesNumNotNegatedNormals, spaLumpAverageVertex, spaLumpVertexAdjacents, {-spaLumpGetVertexAdjacents, -}spaLumpPlanes, + spaBodyBSPs, spaBodyBSPNumPartitions, spaBSPNumPartitions, + SolOtherAnalysis(..), soaPathAtTime, soaPathTransformationAtTime, + soaPathTranslationAtTime, soaPathAtTimeMap, soaPathAtTimeRMap, + soaPathCycle, mkSolAnalysis, mkSolRenderAnalysis, getSpaLumpGetVertexAdjacents, - mkSolPhysicsAnalysis + mkSolPhysicsAnalysis, + mkSolOtherAnalysis ) where import Prelude () @@ -51,21 +59,23 @@ import Data.Foldable import Data.Function hiding (id, (.)) import Data.Int +import Data.List hiding (partition) import Data.Maybe import Control.Lens import Control.Monad.Trans.State.Lazy import Data.Array.IArray -import Data.List import qualified Data.Map.Lazy as M import qualified Data.Set as S +import Data.LabeledBinTree import Immutaball.Ball.LevelSets import Immutaball.Share.Config import Immutaball.Share.Context import Immutaball.Share.ImmutaballIO.GLIO --import Immutaball.Share.Level.Analysis.LowLevel import Immutaball.Share.Level.Base +import Immutaball.Share.Level.Utils import Immutaball.Share.Math import Immutaball.Share.Utils import Immutaball.Share.Video @@ -83,7 +93,10 @@ _saRenderAnalysis :: SolRenderAnalysis, -- | Extra analysis of the sol useful for physics. - _saPhysicsAnalysis :: SolPhysicsAnalysis + _saPhysicsAnalysis :: SolPhysicsAnalysis, + + -- | Analysis that can be used by either rendering or physics. + _saOtherAnalysis :: SolOtherAnalysis } deriving (Eq, Ord, Show) --makeLenses ''SolAnalysis @@ -231,6 +244,33 @@ deriving (Eq, Ord, Show) --makeLenses ''SolRenderAnalysis +newtype LumpBSP = LumpBSP {_lumpBSP :: Tree LumpBSPPartition} + deriving (Eq, Ord, Show) +--makeLenses ''LumpBSP + +-- | A planar partition of the remaining lumps. +data LumpBSPPartition = LumpBSPPartition { + -- | The plane making the partition of the remaining lumps. + _lbsppPlane :: Plane3 Double, + -- | All lumps that intersect this plane. (Either not all vertices are on + -- the same side of the plane, or there is a vertex that intersects the plane.) + _lbsppLumps :: S.Set Int32, + + -- For convenience, we also provide more data. + + -- | The average vertex of lumps intersecting this plane. + _lbsppLumpsMeanVertex :: Vec3 Double, + + -- | Optionally, we can also reference all remaining lumps: i.e. all lumps + -- on this plane, and all lumps on any child node. + _lbsppAllLumps :: S.Set Int32, + -- | The average vertex of all lumps remaining, both on this node and all + -- child nodes. + _lbsppAllLumpsMeanVertex :: Vec3 Double +} + deriving (Eq, Ord, Show) +--makeLenses ''LumpBSPPartition + -- | Extra data of the sol useful for physics. data SolPhysicsAnalysis = SolPhysicsAnalysis { -- | OLD: actually SOL file lump sides I found were not the actual planes @@ -264,15 +304,63 @@ -- | For each lump, we build from the edges and vertices a set of planes -- with normals pointing away from the convex lump. - _spaLumpPlanes :: M.Map Int32 [Plane3 Double] + _spaLumpPlanes :: M.Map Int32 [Plane3 Double], + + -- | Map from body indices to BSPs of those bodies. Bodies in a Sol are + -- sets of lumps that all follow the same translation and rotation path. + _spaBodyBSPs :: M.Map Int32 LumpBSP, + + -- | For each body, how many partitions does it have? + _spaBodyBSPNumPartitions :: M.Map Int32 Integer, + -- | What is the total number of partitions for all bodies? + -- This is intended to be used with ‘par’ to parallelize an early + -- evaluation of all BSPs. + _spaBSPNumPartitions :: Integer } deriving (Eq, Ord, Show) +--makeLenses ''SolPhysicsAnalysis + +-- | Other level analysis, e.g. body calculations for renderer or physics. +data SolOtherAnalysis = SolOtherAnalysis { + -- | Given an origin path (by index), obtain a function from time elapsed + -- to the current path any attached body would be on, along with a value + -- from 0 to 1 representing how far along the path that body would be at + -- that time. + -- Currently only translations are supported. + _soaPathAtTime :: FakeEOS (M.Map Int32 (Double -> (Int32, Double))), + -- | Likewise, but obtain a transformation matrix for the base path, + -- without hierarchical paths. + _soaPathTransformationAtTime :: FakeEOS (M.Map Int32 (Double -> Mat4 Double)), + -- | Offset to apply to the vertices. Also takes number of derivatives to + -- obtain e.g. velocity and acceleration if desired; for position pass 0. + -- Note: beware if derivativeDegree is 1, and the path has travel time 0, + -- there could be an infinite / invalid result; consider 'v3Or', especially + -- in the physics implementation. + _soaPathTranslationAtTime :: FakeEOS (Integer -> M.Map Int32 (Double -> Vec3 Double)), + + -- | Intermediate structure; soaPathAtTime abstracts this. + -- For each path, find the time elapsed (and node index) for each unique + -- node until the end or a cycle is detected. + _soaPathAtTimeMap :: M.Map Int32 (M.Map (Double, Integer) Int32), + _soaPathAtTimeRMap :: M.Map Int32 (M.Map Int32 (Double, Integer)), + -- | Is there a cycle in the path, ignoring last node self-reference? + -- If the last distinct node (‘from’) in the path returns to an earlier + -- node ‘to’, this is (to, cycle period, from), i.e. (cycle start, cycle + -- period, cycle last node). + _soaPathCycle :: M.Map Int32 (Maybe (Int32, Double, Int32)) +} + deriving (Eq, Ord, Show) -- We'll use FakeEOS because we use functions here. +--makeLenses ''SolOtherAnalysis + makeLenses ''SolWithAnalysis makeLenses ''SolAnalysis makeLenses ''SolMeta makeLenses ''SolRenderAnalysis +makeLenses ''LumpBSP +makeLenses ''LumpBSPPartition makeLenses ''GeomPass makeLenses ''SolPhysicsAnalysis +makeLenses ''SolOtherAnalysis sar :: Lens' SolAnalysis SolRenderAnalysis sar = saRenderAnalysis @@ -283,7 +371,8 @@ mkSolAnalysis :: IBContext' a -> Sol -> SolAnalysis mkSolAnalysis cxt sol = fix $ \_sa -> SolAnalysis { _saRenderAnalysis = mkSolRenderAnalysis cxt sol, - _saPhysicsAnalysis = mkSolPhysicsAnalysis cxt sol + _saPhysicsAnalysis = mkSolPhysicsAnalysis cxt sol, + _saOtherAnalysis = mkSolOtherAnalysis cxt sol } mkSolRenderAnalysis :: IBContext' a -> Sol -> SolRenderAnalysis @@ -536,7 +625,7 @@ getSpaLumpGetVertexAdjacents spa = \li vi -> (M.lookup li (spa^.spaLumpVertexAdjacents) >>= M.lookup vi) `morElse` S.empty mkSolPhysicsAnalysis :: IBContext' a -> Sol -> SolPhysicsAnalysis -mkSolPhysicsAnalysis _cxt sol = fix $ \spa -> SolPhysicsAnalysis { +mkSolPhysicsAnalysis _cxt sol = fix $ \spa -> SolPhysicsAnalysis { -- TODO _spaLumpOutwardsSides = (^._1) <$> lumpSidesData spa, _spaLumpOutwardsSidesNumNegatedNormals = (^._2) <$> lumpSidesData spa, _spaLumpOutwardsSidesNumNotNegatedNormals = (^._3) <$> lumpSidesData spa, @@ -547,7 +636,12 @@ {- _spaLumpGetVertexAdjacents = lumpGetVertexAdjacents spa, -} - _spaLumpPlanes = lumpPlanes spa + _spaLumpPlanes = lumpPlanes spa, + + _spaBodyBSPs = bodyBSPs spa, + + _spaBodyBSPNumPartitions = (numElemsLBTI . (^.lumpBSP)) <$> (spa^.spaBodyBSPs), + _spaBSPNumPartitions = sum $ M.elems (spa^.spaBodyBSPNumPartitions) } where indirection :: Int32 -> Int32 @@ -631,7 +725,7 @@ let r = plane return $ r in -- De-duplicate the planes. - let planesDedup = nubBy eqPlane3PointsOnly $ planesStart in + let planesDedup = nubBy nearPlane3PointsOnly $ planesStart in -- Now orient the planes, so that the normal is pointing outwards -- from the convex lump. That is, negate the normal orientation of @@ -646,3 +740,306 @@ -- Return the planes. (li, planesOriented) + + -- | Make a BSP of each body at runtime. + bodyBSPs :: SolPhysicsAnalysis -> M.Map Int32 LumpBSP + bodyBSPs spa = M.fromList . flip map [0..sol^.solBc - 1] $ \bi -> + let body = (sol^.solBv) ! bi in + let bodyLumpIndicesRaw = [body^.bodyL0 .. body^.bodyL0 + body^.bodyLc - 1] in + -- Discard detail lumps. + let bodyLumpIndices = [li | li <- bodyLumpIndicesRaw, let lump = (sol^.solLv) ! li, ((lump^.lumpFl) .&. lumpFlagDetail) == 0] in + let (firstPartition :: LumpBSPPartition) = fix $ \partition -> LumpBSPPartition { + _lbsppPlane = + let allMean = (partition^.lbsppAllLumpsMeanVertex) in + let allLumps = (partition^.lbsppAllLumps) in + let initialNormal = v3normalize . correctNormal $ (Vec3 1 0 0) in + -- Make sure there is always at least 1 lump in a + -- partition: instead of using allMean for the point for + -- our plane, find the closest lump to the mean and use its + -- mean. + let allMean' = closestLumpMean allLumps allMean in + normalizePlane3 allMean' (refineNormal allLumps allMean' initialNormal), + _lbsppLumps = S.filter (lumpIntersectsPlane (partition^.lbsppPlane)) (partition^.lbsppAllLumps), + + _lbsppLumpsMeanVertex = lumpsAverageVertex (partition^.lbsppLumps), + + _lbsppAllLumps = S.fromList bodyLumpIndices, + _lbsppAllLumpsMeanVertex = lumpsAverageVertex (partition^.lbsppAllLumps) + } in + (,) bi . LumpBSP . normalizeLabeledBinTree . + (\f -> (f :: LumpBSPPartition -> Tree LumpBSPPartition) firstPartition) . fix $ \makeTree -> + \parentPartition -> + if' (S.null (parentPartition^.lbsppAllLumps)) (leafLBT parentPartition) $ + forkLBT + (makeTree . fix $ \partition -> LumpBSPPartition { + _lbsppPlane = + let allMean = (partition^.lbsppAllLumpsMeanVertex) in + let allLumps = (partition^.lbsppAllLumps) in + let initialNormal = v3normalize . correctNormal $ (parentPartition^.lbsppPlane.abcp3) `vx3` ((partition^.lbsppAllLumpsMeanVertex) - (parentPartition^.lbsppAllLumpsMeanVertex)) in + -- Make sure there is always at least 1 lump in a + -- partition: instead of using allMean for the point for + -- our plane, find the closest lump to the mean and use its + -- mean. + let allMean' = closestLumpMean allLumps allMean in + normalizePlane3 allMean' (refineNormal allLumps allMean' initialNormal), + _lbsppLumps = S.filter (lumpIntersectsPlane (partition^.lbsppPlane)) (partition^.lbsppAllLumps), + + _lbsppLumpsMeanVertex = lumpsAverageVertex (partition^.lbsppLumps), + + _lbsppAllLumps = S.filter (\li -> lumpPlaneSide (parentPartition^.lbsppPlane) li == (-1)) (parentPartition^.lbsppAllLumps), + _lbsppAllLumpsMeanVertex = lumpsAverageVertex (partition^.lbsppAllLumps) + }) + (parentPartition & lbsppLumps %~ assertNonNull) + (makeTree . fix $ \partition -> LumpBSPPartition { + _lbsppPlane = + let allMean = (partition^.lbsppAllLumpsMeanVertex) in + let allLumps = (partition^.lbsppAllLumps) in + let initialNormal = v3normalize . correctNormal $ (parentPartition^.lbsppPlane.abcp3) `vx3` ((partition^.lbsppAllLumpsMeanVertex) - (parentPartition^.lbsppAllLumpsMeanVertex)) in + -- Make sure there is always at least 1 lump in a + -- partition: instead of using allMean for the point for + -- our plane, find the closest lump to the mean and use its + -- mean. + let allMean' = closestLumpMean allLumps allMean in + normalizePlane3 allMean' (refineNormal allLumps allMean' initialNormal), + _lbsppLumps = S.filter (lumpIntersectsPlane (partition^.lbsppPlane)) (partition^.lbsppAllLumps), + + _lbsppLumpsMeanVertex = lumpsAverageVertex (partition^.lbsppLumps), + + _lbsppAllLumps = S.filter (\li -> lumpPlaneSide (parentPartition^.lbsppPlane) li == 1) (parentPartition^.lbsppAllLumps), + _lbsppAllLumpsMeanVertex = lumpsAverageVertex (partition^.lbsppAllLumps) + }) + + where + lumpsAverageVertex :: S.Set Int32 -> Vec3 Double + lumpsAverageVertex lumps = + steppingMean . + --setMapFilter (\li -> flip M.lookup (spa^.spaLumpAverageVertex) li) $ + S.map (\x -> x `morElse` error "Internal error: mkSolPhysicsAnalysis lumpsAverageVertex failed to find average vertex for a lump") . + S.map (\li -> flip M.lookup (spa^.spaLumpAverageVertex) li) $ + lumps + + lumpIntersectsPlane :: Plane3 Double -> Int32 -> Bool + {- + lumpIntersectsPlane plane li = + let lump = (sol^.solLv) ! li in + let vis = indirection <$> [lump^.lumpV0..lump^.lumpV0 + lump^.lumpVc - 1] in + let vs = (^.vertP) . ((sol^.solVv) !) <$> vis in + -- Which side is each vertex on? + let sides = map thresholdSignnum . map (plane3PointDistance plane) $ vs in + let anyVertOnPlane = any (== 0) sides in + let lumpCrossesPlane = length (nub sides) > 1 in + anyVertOnPlane || lumpCrossesPlane + -} + lumpIntersectsPlane plane li = lumpPlaneSide plane li == 0 + + -- | Does the lump intersect the plane? Classify as 0. + -- Otherwise, classify by whether all lump vertices are behind (-1) or + -- in front of (1) the plane. + lumpPlaneSide :: Plane3 Double -> Int32 -> Integer + lumpPlaneSide plane li = + let lump = (sol^.solLv) ! li in + let vis = indirection <$> [lump^.lumpV0..lump^.lumpV0 + lump^.lumpVc - 1] in + let vs = (^.vertP) . ((sol^.solVv) !) <$> vis in + -- Which side of the plane is each vertex on? + let sides = map thresholdSignnumI . map (plane3PointDistance plane) $ vs in + let anyVertOnPlane = any (== 0) sides in + let lumpCrossesPlane = length (nub sides) > 1 in + if' (anyVertOnPlane || lumpCrossesPlane || null sides) ( 0) . + if' (all (<= 0) sides) (-1) $ + id ( 1) + + -- | If the normal is small, default to Vec3 1 0 0; otherwise, normalize it. + correctNormal :: Vec3 Double -> Vec3 Double + correctNormal v + | (v^.r3) - smallishNum <= threshold = v3normalize $ Vec3 1 0 0 + | otherwise = v3normalize $ v + where threshold = 0.001 + + -- | Given a set of lumps, the mean mean vertex of those lumps, + -- and an initial normal, try to produce a better normal that + -- minimizes the difference in size between lumps in front of + -- and behind the plane ‘normalizePlane3 mean normal’. i.e. we + -- made a guess as to a good partition of the lumps, and try to + -- refine the normal of the plane to equalize the number of + -- lumps of each side. + refineNormal :: S.Set Int32 -> Vec3 Double -> Vec3 Double -> Vec3 Double + refineNormal lis mean lastNormal0 = + (\f -> (f :: Integer -> Vec3 Double -> Vec3 Double) maxIterations lastNormal0) . fix $ \iterate_ iterationsRemaining lastNormal -> + if' (iterationsRemaining <= 0) (lastNormal) . + if' (inequality' lastNormal <= 1) (lastNormal) $ + let tryNormal = lumpsAverageVertex . flip S.filter lis $ \li -> lumpPlaneSide (normalizePlane3 mean lastNormal) li == 1 in + if' (inequality' tryNormal > inequality' lastNormal) (lastNormal) $ + iterate_ (iterationsRemaining - 1) tryNormal + where + maxIterations :: Integer + maxIterations = 8 + + -- | Given a normal, what is the difference in number + -- of lumps on each side? + _inequality :: Vec3 Double -> Integer + _inequality tryNormal = + let sidesNotOn = S.filter (/= 0) . S.map (lumpPlaneSide (normalizePlane3 mean tryNormal)) $ lis in + let numBehind = setSize . S.filter (<= 0) $ sidesNotOn in + let numAhead = setSize sidesNotOn - numBehind in + abs $ numAhead - numBehind + + setSize :: S.Set a -> Integer + setSize = fromIntegral . S.size + + -- | Adjust inequality by adding a cost of having more + -- lumps (after the first) _on_ the plane, since these + -- always have to checked before descending in the tree for e.g. + -- collisions. + inequality' :: Vec3 Double -> Integer + inequality' tryNormal = + let sidesNotOn = S.filter (/= 0) . S.map (lumpPlaneSide (normalizePlane3 mean tryNormal)) $ lis in + let numBehind = setSize . S.filter (<= 0) $ sidesNotOn in + let numAhead = setSize sidesNotOn - numBehind in + let numOn = setSize lis - setSize sidesNotOn in + (abs $ numAhead - numBehind) + 2 * numOn + + -- | Given a set of lumps and a point, find the lump whose mean + -- is closest to that point, and return its mean. + closestLumpMean :: S.Set Int32 -> Vec3 Double -> Vec3 Double + closestLumpMean allLumps allMean = (safeHead . sortOn (\mean -> (mean - allMean)^.r3) . map liToMean . S.toList $ allLumps) `morElse` allMean + where liToMean li = flip M.lookup (spa^.spaLumpAverageVertex) li `morElse` error ("Internal error: mkSolPhysicsAnalysis closestLumpMean could not find mean vertex of lump ‘" ++ (show li) ++ "’.") + + assertNonNull :: S.Set a -> S.Set a + assertNonNull s = if' (S.null s) (error "Internal error: mkSolPhysicsAnalysis bodyBSPs assertNonNull: each non-leaf partition should have at least 1 lump, but this partition didn't!") (s) + +-- | Given a sol, construct a 'SolOtherAnalysis' from it. +-- TODO +mkSolOtherAnalysis :: IBContext' a -> Sol -> SolOtherAnalysis +mkSolOtherAnalysis _cxt sol = fix $ \soa -> SolOtherAnalysis { + _soaPathAtTime = FakeEOS $ theSoaPathAtTime soa, + _soaPathTransformationAtTime = FakeEOS $ theSoaPathTransformationAtTime soa, + _soaPathTranslationAtTime = FakeEOS $ theSoaPathTranslationAtTime soa, + _soaPathAtTimeMap = theSoaPathAtTimeMap soa, + _soaPathAtTimeRMap = theSoaPathAtTimeRMap soa, + _soaPathCycle = theSoaPathCycle soa +} + where + theSoaPathAtTime :: SolOtherAnalysis -> M.Map Int32 (Double -> (Int32, Double)) + theSoaPathAtTime soa = (`M.mapWithKey` (soa^.soaPathAtTimeMap)) $ \pi_ _atTimeMap -> \t -> + -- First check if ‘t’ has entered a cycle. + let (mcycleDuration :: Maybe Double) = do + pathCyclePi <- flip M.lookup (soa^.soaPathCycle) pi_ + cycleDuration <- (^._2) <$> pathCyclePi + return cycleDuration in + let (mcycleStartAt :: Maybe Double) = do + pathCyclePi <- flip M.lookup (soa^.soaPathCycle) $ pi_ + cycleStart <- (^._1) <$> pathCyclePi + atTimeR <- flip M.lookup (soa^.soaPathAtTimeRMap) $ pi_ + (cycleStartAt, _cycleStartIndex) <- flip M.lookup atTimeR $ cycleStart + return cycleStartAt in + let (isCycle :: Bool) = ((t >=) <$> mcycleStartAt) == Just True in + -- If there's a cycle, just wrap t around the cycle period to loop back. + let (t' :: Double) = (`morElse` t) $ do + cycleDuration <- mcycleDuration + cycleStartAt <- mcycleStartAt + guard $ isCycle + let (timeOnCycle :: Double) = t - cycleStartAt + let (wrappedTimeOnCycle :: Double) = timeOnCycle `modfl` cycleDuration + return $ cycleStartAt + wrappedTimeOnCycle in + -- Now find the node it's on, and turn it into a path and time elapsed. + (`morElse` (pi_, 0.0)) $ do + pathAtTimeMap <- flip M.lookup (soa^.soaPathAtTimeMap) pi_ + (k, v) <- flip M.lookupLE pathAtTimeMap (t', -1) + let (nodeStarts :: Double) = k^._1 + let (node :: Int32) = v + let (timeOnNode :: Double) = t' - nodeStarts + + guard . inRange (bounds $ sol^.solPv) $ node + let (path :: Path) = (sol^.solPv) ! node + let (pathTime :: Double) = path^.pathT + -- progressOnNode: from 0 to 1, for 0 at start, 1 at end. + let (progressOnNode :: Double) = ilerp 0.0 pathTime timeOnNode + + return $ (node, progressOnNode) + + theSoaPathTransformationAtTime :: SolOtherAnalysis -> M.Map Int32 (Double -> Mat4 Double) + theSoaPathTransformationAtTime soa = (<$> (soa^.soaPathTranslationAtTime.fakeEOS) 0) $ \f -> \t -> + let (netPosCorrected :: Vec3 Double) = f t in + + let (translate :: Mat4 Double) = translate3 netPosCorrected in + + translate + + theSoaPathTranslationAtTime :: SolOtherAnalysis -> Integer -> M.Map Int32 (Double -> Vec3 Double) + theSoaPathTranslationAtTime soa = \derivativeDegree -> (`M.mapWithKey` (soa^.soaPathAtTime.fakeEOS)) $ \pi_ atTime -> \t -> + (`morElse` zv3) $ do + -- Get origin path. + guard . inRange (bounds $ sol^.solPv) $ pi_ -- Redundant. + let (originPath :: Path) = (sol^.solPv) ! pi_ + + -- Get the path that would be current at time t, relative to + -- the origin path. + let (onNode, (progressOnNode :: Double)) = atTime t + guard . inRange (bounds $ sol^.solPv) $ onNode -- Redundant. + let (onPath :: Path) = (sol^.solPv) ! onNode + + let nextNode = onPath^.pathPi + guard . inRange (bounds $ sol^.solPv) $ nextNode + let (nextPath :: Path) = (sol^.solPv) ! nextNode + + let (originPos :: Vec3 Double) = originPath^.pathP + let (pathPos :: Vec3 Double) = onPath^.pathP + let (nextPos :: Vec3 Double) = nextPath^.pathP + let (lerpPos :: Vec3 Double) + | derivativeDegree == 0 = lerpV3 pathPos nextPos progressOnNode + -- If derivativeDegre is 1, and the path has travel time0, + -- beware this could give us an infinite or invalid + -- velocity vector. + | derivativeDegree == 1 = (nextPos - pathPos)/(rv3$onPath^.pathT) + | otherwise = zv3 + let (solErpPos :: Vec3 Double) + | derivativeDegree == 0 = lerpV3 pathPos nextPos . solErp $ progressOnNode + | otherwise = + solErpdn derivativeDegree progressOnNode `sv3` ((nextPos - pathPos)/(rv3$onPath^.pathT)) + + let (selectLerpPos :: Vec3 Double) = if' (onPath^.pathS /= 0) solErpPos lerpPos + + let (netPos :: Vec3 Double) = selectLerpPos - originPos + let (netPosCorrected :: Vec3 Double) = netPos + originPos -- SOL seems to require adding originPos to get the correct positioning. + + return $ netPosCorrected + + -- | Traverse each path until the end is reached or there is a cycle. + -- Record how much total time elapsed would be required to start each + -- node in the path. + theSoaPathAtTimeMap :: SolOtherAnalysis -> M.Map Int32 (M.Map (Double, Integer) Int32) + theSoaPathAtTimeMap _soa = M.fromList . flip map [0..(sol^.solPc)-1] $ \pi_ -> (,) pi_ . + M.fromList . flip fix (0.0, S.empty, pi_, 0) $ \me (elapsed, visited, pni, nodeIndex) -> + if' (pni `S.member` visited) [] . + if' (not . inRange (bounds $ sol^.solPv) $ pni) [] $ + let pn = (sol^.solPv) ! pni in + let node = ((elapsed, nodeIndex), pni) in + node : me (elapsed + pn^.pathT, S.insert pni visited, pn^.pathPi, nodeIndex + 1) + theSoaPathAtTimeRMap :: SolOtherAnalysis -> M.Map Int32 (M.Map Int32 (Double, Integer)) + theSoaPathAtTimeRMap soa = (M.fromList . fmap swap . M.toList) <$> (soa^.soaPathAtTimeMap) + + -- | For each path, check for a cycle: (to, cycle time elapsed, from). + theSoaPathCycle :: SolOtherAnalysis -> M.Map Int32 (Maybe (Int32, Double, Int32)) + theSoaPathCycle soa = (`M.mapWithKey` (soa^.soaPathAtTimeMap)) $ \pi_ atTime -> do + timeAtPathMap <- flip M.lookup (soa^.soaPathAtTimeRMap) $ pi_ + (lastNodeKey :: (Double, Integer)) <- S.lookupMax . M.keysSet $ atTime + (lastNode :: Int32) <- flip M.lookup atTime lastNodeKey + guard . inRange (bounds $ sol^.solPv) $ lastNode -- Redundant; lastNode should be valid, but not necessarily lastNodeNext. + let lastPath = (sol^.solPv) ! lastNode + guard $ (lastPath^.pathPi) /= lastNode + + let lastNodeNext = lastPath^.pathPi + guard . inRange (bounds $ sol^.solPv) $ lastNodeNext + + (lastNodeNextKey :: (Double, Integer)) <- flip M.lookup timeAtPathMap lastNodeNext + + -- From start of earlier to start of last (to - from). + let (earlierToLastDuration :: Double) = (lastNodeKey^._1) - (lastNodeNextKey^._1) + -- Now just add the duration of the last node itself. + let (lastNodeDuration :: Double) = lastPath^.pathT + let (cycleDuration :: Double) = earlierToLastDuration + lastNodeDuration + + -- (cycle start, cycle period, cycle last node) + let (to_, cyclePeriod, from_) = (lastNodeNext, cycleDuration, lastNode) + let (cycleStart, cyclePeriod', cycleLastNode) = (to_, cyclePeriod, from_) + return (cycleStart, cyclePeriod', cycleLastNode) diff --git a/Immutaball/Share/Level/Render.hs b/Immutaball/Share/Level/Render.hs deleted file mode 100644 --- a/Immutaball/Share/Level/Render.hs +++ /dev/null @@ -1,265 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-tabs #-} -- Support tab indentation better, for a better default of no warning if tabs are used: https://dmitryfrank.com/articles/indent_with_tabs_align_with_spaces . --- Enable warnings: -{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} - --- Level/Render.hs. - -{-# LANGUAGE Haskell2010 #-} -{-# LANGUAGE Arrows, ScopedTypeVariables #-} - --- | TODO: split shared render into shared and ball render. --- --- Currently this uses ball game state. -module Immutaball.Share.Level.Render - ( - renderLevel, - renderSetupNewLevel, - renderScene, - renderGeomPass - ) where - -import Prelude () -import Immutaball.Prelude - -import Control.Arrow -import Control.Monad -import Data.Int -import Data.Ix -import Data.Maybe - -import Control.Lens -import Data.Array.IArray -import qualified Data.Map.Lazy as M -import Graphics.GL.Compatibility45 ---import Graphics.GL.Core45 -import Graphics.GL.Types - -import Immutaball.Ball.Game -import Immutaball.Share.Config -import Immutaball.Share.Context -import Immutaball.Share.ImmutaballIO.GLIO -import Immutaball.Share.Level.Analysis -import Immutaball.Share.Level.Base -import Immutaball.Share.Math -import Immutaball.Share.SDLManager -import Immutaball.Share.State -import Immutaball.Share.State.Context -import Immutaball.Share.Utils -import Immutaball.Share.Video -import Immutaball.Share.Wire - -renderLevel :: Wire ImmutaballM ((MView, SolWithAnalysis, GameState), IBStateContext) IBStateContext -renderLevel = proc ((camera_, swa, gs), cxtn) -> do - -- Set up. - let levelPath = swa^.swaMeta.smPath - (mlastLevelPath, cxtnp1) <- setCurrentlyLoadedSOL -< (levelPath, cxtn) - let newLevel = not $ Just levelPath == mlastLevelPath - cxtnp2 <- returnA ||| renderSetupNewLevel -< if' (not newLevel) (Left cxtnp1) (Right (swa, cxtnp1)) - - -- Render the scene. - cxtnp3 <- renderScene -< ((camera_, swa, gs), cxtnp2) - - -- Return the state context. - - let cxt = cxtnp3 - returnA -< cxt - -renderSetupNewLevel :: Wire ImmutaballM (SolWithAnalysis, IBStateContext) IBStateContext -renderSetupNewLevel = proc (swa, cxtn) -> do - let sra = swa^.swaSa.saRenderAnalysis - - -- Upload SSBOs. - cxtnp1 <- setSSBO -< ((shaderSSBOVertexDataLocation, sra^.sraVertexDataGPU), cxtn) - cxtnp2 <- setSSBO -< ((shaderSSBOGeomDataLocation, sra^.sraGeomDataGPU), cxtnp1) - cxtnp3 <- setSSBO -< ((shaderSSBOLumpDataLocation, sra^.sraLumpDataGPU), cxtnp2) - cxtnp4 <- setSSBO -< ((shaderSSBOPathDoublesDataLocation, sra^.sraPathDoublesDataGPU), cxtnp3) - cxtnp5 <- setSSBO -< ((shaderSSBOPathInt32sDataLocation, sra^.sraPathInt32sDataGPU), cxtnp4) - cxtnp6 <- setSSBO -< ((shaderSSBOBodyDataLocation, sra^.sraBodyDataGPU), cxtnp5) - cxtnp7 <- setSSBO -< ((shaderSSBOGcDataLocation, sra^.sraGcArrayGPU), cxtnp6) - cxtnp8 <- setSSBO -< ((shaderSSBOAllGeomPassMvDataLocation, sra^.sraAllGeomPassMvGPU), cxtnp7) - cxtnp9 <- setSSBO -< ((shaderSSBOAllGeomPassTexturesDataLocation, sra^.sraAllGeomPassTexturesGPU), cxtnp8) - cxtnp10 <- setSSBO -< ((shaderSSBOAllGeomPassGisDataLocation, sra^.sraAllGeomPassGisGPU), cxtnp9) - cxtnp11 <- setSSBO -< ((shaderSSBOGeomPassMvRangesDataLocation, sra^.sraGeomPassMvRangesGPU), cxtnp10) - cxtnp12 <- setSSBO -< ((shaderSSBOGeomPassTexturesRangesDataLocation, sra^.sraGeomPassTexturesRangesGPU), cxtnp11) - cxtnp13 <- setSSBO -< ((shaderSSBOGeomPassGisRangesDataLocation, sra^.sraGeomPassGisRangesGPU), cxtnp12) - cxtnp14 <- setSSBO -< ((shaderSSBOGeomPassBisDataLocation, sra^.sraGeomPassBisGPU), cxtnp13) - cxtnp15 <- setSSBO -< ((shaderSSBOTexcoordsDoubleDataLocation, sra^.sraTexcoordsDoubleDataGPU), cxtnp14) - - -- Upload elems vao and buf. - cxtnp16 <- setElemVaoVboEbo -< (sra^.sraGcArrayGPU, True, cxtnp15) - - -- Pre-initialize the transformation matrix with the identity. - cxtnp17 <- setTransformation -< (identity4, cxtnp16) - - -- Approximate disabling OpenGL clipping by depth (by our transformed y coordinates, which transform into OpenGL z depth coordinates). - -- Also other miscellaneous OpenGL setup. - let sdlGL1'_ = sdlGL1 (cxtnp17^.ibContext.ibSDLManagerHandle) - let sdlGL1' = liftIBIO . sdlGL1'_ - () <- monadic -< sdlGL1' $ do - -- TODO FIXME: this doesn't seem to actually stop clipping for depth - -- values outside a certain range. - -- - -- To investigate, disable rescaleDepth, try retour de force level 2, - -- enable free camera, and rotate the camera until you can see the - -- level. Move toward that location, and then you can see that the - -- distance from the camera needs to be only within a certain range. - -- - -- So instead we'll just use rescaleDepth. - GLDepthRange (cxtnp17^.ibContext.ibStaticConfig.x'glNearVal) (cxtnp17^.ibContext.ibStaticConfig.x'glFarVal) () - -- Other miscellaneous OpenGL setup. - () <- monadic -< sdlGL1' $ do - --GLPlaceholder GL_VAL () - pure () - - -- Return the state context. - - let cxt = cxtnp17 - - returnA -< cxt - --- | After setup, render the scene. -renderScene :: Wire ImmutaballM ((MView, SolWithAnalysis, GameState), IBStateContext) IBStateContext -renderScene = proc ((camera_, swa, gs), cxtn) -> do - -- Set up the transformation matrix. - --let mat = transformationMatrix camera_ - mat <- arr $ uncurry3 transformationMatrix -< (cxtn, gs, camera_) - cxtnp1 <- setTransformation -< (mat, cxtn) - - -- Render the scene. - let - sol :: Sol - sol = swa^.swaSol - - sa :: SolAnalysis - sa = swa^.swaSa - - sra :: SolRenderAnalysis - sra = sa^.saRenderAnalysis - let _unused = (sol) - - let - ourFlatten :: (Int32, (SolWithAnalysis, GameState, Bool, GeomPass)) -> (Int32, SolWithAnalysis, GameState, Bool, GeomPass) - ourFlatten (a, (b, c, d, e)) = (a, b, c, d, e) - let geomPasses = map ourFlatten . zip [0..] $ map (\gp -> (swa, gs, False, gp)) (sra^.sraOpaqueGeoms) ++ map (\gp -> (swa, gs, True, gp)) (sra^.sraTransparentGeoms) - cxtnp2 <- foldlA renderGeomPass -< (cxtnp1, geomPasses) - - -- Return the state context. - let cxt = cxtnp2 - - returnA -< cxt - - where - uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d - uncurry3 f (a, b, c) = f a b c - - transformationMatrix :: IBStateContext -> GameState -> MView -> Mat4 Double - transformationMatrix cxt gs view_ = worldToGL <> rescaleDepth depthScale 0 <> viewMat' viewCollapse view_ <> tilt - where - x'cfg = cxt^.ibContext.ibStaticConfig - depthScale = x'cfg^.x'cfgDepthScale - viewCollapse = x'cfg^.x'cfgViewCollapse - - -- Translate to the ball (negated actually), rotate by gsCameraAngle, tilt3z, and untranslate. - tilt = - translate3 (gs^.gsBallPos) <> -- Finally, undo the first translation. - tilt3z (gsa^.gsaUpVec) <> -- Tilt the world. - rotatexy (-gs^.gsCameraAngle) <> -- Rotate camera. - translate3 (-gs^.gsBallPos) -- First, go to ball (negated actually). - gsa = mkGameStateAnalysis cxt gs - --- | Render a partition of the level geometry, so that we can handle processing up to 16 textures at a time. -renderGeomPass :: Wire ImmutaballM (IBStateContext, (Int32, SolWithAnalysis, GameState, Bool, GeomPass)) IBStateContext -renderGeomPass = proc (cxtn, (geomPassIdx, swa, _gs, isAlpha, gp)) -> do - -- Setup. - let sdlGL1'_ = sdlGL1 (cxtn^.ibContext.ibSDLManagerHandle) - let sdlGL1' = liftIBIO . sdlGL1'_ - - -- Render the geom pass. - - -- Render all 16 mtrls in the geom pass. - (mtrlsMeta :: [((WidthHeightI, GLuint), MtrlMeta)], cxtnp1) <- - foldrA cachingRenderMtrlAccum -< (([], cxtn), map (\mi -> (swa^.swaSol, mi)) (elems (gp^.gpMv))) - let (mtrlsGlTextures :: [GLuint]) = map (fst >>> snd) mtrlsMeta - let (assignTextures :: GLIOF ()) = do - forM_ (zip [0..] mtrlsGlTextures) $ \(idx, glTexture) -> do - case flip M.lookup numToGL_TEXTUREi idx of - Nothing -> return () - Just gl_TEXTUREi -> do - -- Apparently actually we set GL_TEXTUREi for the texture() - -- GLSL call, not the texture name. So set the i used in - -- GL_TEXTUREi as the value, not the texture identifier. - --GLUniform1i (fromIntegral idx) (fromIntegral texture) () - GLUniform1i (fromIntegral idx) (fromIntegral idx) () - - --GLActiveTexture GL_TEXTUREi () - GLActiveTexture gl_TEXTUREi () - GLBindTexture GL_TEXTURE_2D glTexture () - - -- Render all geometry in this geom pass. - (melemVaoVboEbo, cxtnp2) <- getElemVaoVboEbo -< cxtnp1 - let elemVaoVboEbo = fromMaybe (error "Internal error: renderGeomPass expected elem vao and buf to be present, but it's missing!") melemVaoVboEbo - let (elemVao, _elemVbo, _elemEbo) = elemVaoVboEbo - let (renderGeomPassScene :: GLIOF ()) = do - -- Tell the shaders to enable the scene data. - GLUniform1i shaderEnableSceneDataLocation trueAsIntegral () - -- Tell the shaders we are not drawing the ball right now. - GLUniform1i shaderEnableBallDataLocation falseAsIntegral () - - -- Tell the shaders what geom pass to use. - GLUniform1i (shaderSceneGeomPassIdxLocation) (fromIntegral geomPassIdx) () - - -- Tell the shaders to render this pass's geometries. It will handle the rest; it already has the geom pass data we uploaded upon setup. - GLBindVertexArray elemVao () - - -- Use the vao to tell the shader to draw the geometry. - let numGpGis = rangeSize . bounds $ gp^.gpGis - GLDrawArrays GL_TRIANGLES 0 (fromIntegral (3 * numGpGis)) () - - -- Unbind the VAO. - GLBindVertexArray 0 () - - let (alphaSetup :: GLIOF ()) = do - if isAlpha - then do - GLEnable GL_BLEND () - GLBlendEquationSeparate GL_FUNC_ADD GL_FUNC_ADD () - GLBlendFuncSeparate GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA GL_ONE GL_ZERO () - - GLEnable GL_DEPTH_TEST () - GLDepthMask GL_FALSE () - else do - GLDisable GL_BLEND () - - GLEnable GL_DEPTH_TEST () - GLDepthMask GL_TRUE () - let (alphaFinish :: GLIOF ()) = do - if isAlpha - then do - GLDisable GL_BLEND () - - GLDepthMask GL_TRUE () - else do - GLDisable GL_BLEND () - - GLDepthMask GL_TRUE () - - -- Now aggregate the rendering to render the geom pass. - let (renderGeomPassGL :: GLIOF ()) = do - alphaSetup - assignTextures - renderGeomPassScene - alphaFinish - () <- monadic -< sdlGL1' renderGeomPassGL - - -- Return the state context. - let cxt = cxtnp2 - returnA -< cxt - - where - -- | Add 2 variants: lookup sol mtrl for path, and also accumulate results in a list. - cachingRenderMtrlAccum :: Wire ImmutaballM ((LevelIB, Int32), ([((WidthHeightI, GLuint), MtrlMeta)], IBStateContext)) ([((WidthHeightI, GLuint), MtrlMeta)], IBStateContext) - cachingRenderMtrlAccum = proc ((sol, mi), (accum_, cxtn)) -> do - let mtrl = (sol^.solMv) ! mi - let mtrlPath = mtrl^.mtrlF - (glTextureMeta, cxtnp1) <- cachingRenderMtrl -< (mtrlPath, cxtn) - returnA -< (glTextureMeta:accum_, cxtnp1) diff --git a/Immutaball/Share/Level/Utils.hs b/Immutaball/Share/Level/Utils.hs --- a/Immutaball/Share/Level/Utils.hs +++ b/Immutaball/Share/Level/Utils.hs @@ -13,7 +13,9 @@ transformSol, restoreSolTransformation, restoreSolTransformationSimple, - mapcSolTransformationSimple + mapcSolTransformationSimple, + solErp, + solErpdn ) where import Prelude () @@ -72,3 +74,16 @@ (Vec3 1.0 0.0 0.0) (Vec3 0.0 0.0 1.0) (Vec3 0.0 (-1.0) 0.0) + +-- | Convert a linear parameter (e.g. from 0 to 1) to a parameter that reflects +-- the sol ‘erp’ interpolation formula, for smooth paths. +solErp :: (Fractional a) => a -> a +solErp t = -2.0*t*t*t + 3.0*t*t + +-- | Variant of 'solErp' that calculates derivatives an arbitrary number of times. +solErpdn :: (Fractional a) => Integer -> a -> a +solErpdn 0 t = -2.0*t*t*t + 3.0*t*t -- -2t^3 + 3t^2 +solErpdn 1 t = -6.0*t*t + 6.0*t -- -6t^2 + 6t +solErpdn 2 t = -12.0*t + 6.0 -- -12t + 6 +solErpdn 3 _t = -12.0 -- -12 +solErpdn _ _t = 0 diff --git a/Immutaball/Share/Math/Core.hs b/Immutaball/Share/Math/Core.hs --- a/Immutaball/Share/Math/Core.hs +++ b/Immutaball/Share/Math/Core.hs @@ -23,6 +23,7 @@ r2, t2, Vec3(..), x3, y3, z3, + rv3, pv3, sv3, minusv3, @@ -113,6 +114,10 @@ v2orWith, v3or, v3orWith, + v4or, + v4orWith, + flor, + florWith, vx3, v2perp, v3perp, @@ -206,12 +211,12 @@ worldToGLSimple, rescaleDepth, - -- * 3D vector aiming rotation utils in radians: horizontal and vertical aiming of a point relative to origin. + -- * 3D vector aiming rotation utils in radians: horizontal and vertical aiming of a point relative to origin aimHoriz3DSimple, aimVert3DSimple, - -- * More utils. + -- * More utils v2z, v2s, v2nzElse, @@ -225,7 +230,7 @@ v4nzElse, v4nsElse, - -- * Subvectors. + -- * Subvectors xy3, xz3, yz3, @@ -240,7 +245,13 @@ xzw4, yzw4, - sqx + sqx, + + -- * Equivalence and sign utils + thresholdSignnum, + nearSignnum, + thresholdSignnumI, + nearSignnumI ) where import Prelude () @@ -282,6 +293,9 @@ abs = fmap abs (*) = cm2 signum = fmap signum +instance (Num a, Fractional a) => Fractional (Vec2 a) where + a / b = a * (recip <$> b) + fromRational = rv2 . fromRational rv2 :: a -> Vec2 a rv2 z = Vec2 z z @@ -372,6 +386,9 @@ abs = fmap abs (*) = cm3 signum = fmap signum +instance (Num a, Fractional a) => Fractional (Vec3 a) where + a / b = a * (recip <$> b) + fromRational = rv3 . fromRational rv3 :: a -> Vec3 a rv3 z = Vec3 z z z @@ -448,6 +465,9 @@ abs = fmap abs (*) = cm4 signum = fmap signum +instance (Num a, Fractional a) => Fractional (Vec4 a) where + a / b = a * (recip <$> b) + fromRational = rv4 . fromRational rv4 :: a -> Vec4 a rv4 z = Vec4 z z z z @@ -1012,6 +1032,25 @@ | isNaN z || isInfinite z = else_ | otherwise = v +v4or :: (RealFloat a) => Vec4 a -> Vec4 a +v4or = v4orWith (Vec4 0.0 0.0 0.0 0.0) + +v4orWith :: (RealFloat a) => Vec4 a -> Vec4 a -> Vec4 a +v4orWith else_ v@(Vec4 x y z w) + | isNaN x || isInfinite x = else_ + | isNaN y || isInfinite y = else_ + | isNaN z || isInfinite z = else_ + | isNaN w || isInfinite w = else_ + | otherwise = v + +flor :: (RealFloat a) => a -> a +flor = florWith 0.0 + +florWith :: (RealFloat a) => a -> a -> a +florWith else_ x + | isNaN x || isInfinite x = else_ + | otherwise = x + -- | Cross product. -- -- Satisfies a x b = |a| * |b| * sin(t) * n, providing a vector perpendicular @@ -1867,7 +1906,7 @@ where (do_, ds) = (depthTranslate, depthScale) --- * 3D vector aiming rotation utils in radians: horizontal and vertical aiming of a point relative to origin. +-- * 3D vector aiming rotation utils in radians: horizontal and vertical aiming of a point relative to origin -- | The vector represents where the camera at the origin is pointing. Rotate -- aim right by ‘radiansRight’ radians. @@ -1913,7 +1952,7 @@ Nothing -> radiansUp Just _ -> min maxRadiansUp . max minRadiansUp $ radiansUp --- * More utils. +-- * More utils -- | Is the vector zero? v2z :: (SmallNum a, Ord a, Num a, RealFloat a) => Vec2 a -> Bool @@ -1963,7 +2002,7 @@ v4nsElse :: (SmallishNum a, Ord a, Num a, RealFloat a) => Vec4 a -> Vec4 a -> Vec4 a v4nsElse v else_ = if' (not $ v4s v) v else_ --- * Subvectors. +-- * Subvectors -- | Handle just the ‘xy’ vector in a Vec3. xy3 :: forall a. Lens' (Vec3 a) (Vec2 a) @@ -2085,3 +2124,33 @@ -- | Convenient utility to square a number. sqx :: forall a. (Num a) => a -> a sqx x = x*x + +-- * Equivalence and sign utils + +-- | Determine if the number is zero, negative, or positive. +thresholdSignnum :: forall a i. (SmallNum a, Num a, Ord a, Num i) => a -> i +thresholdSignnum x + | x `equivalentSmall` 0 = 0 + | x <= 0 = -1 + | otherwise = 1 + +-- | 'nearSignum' specialized to Integer. +nearSignnum :: forall a i. (SmallishNum a, Num a, Ord a, Num i) => a -> i +nearSignnum x + | x `near` 0 = 0 + | x <= 0 = -1 + | otherwise = 1 + +-- | 'thresholdSignum' specialized to Integer. +thresholdSignnumI :: forall a. (SmallNum a, Num a, Ord a) => a -> Integer +thresholdSignnumI x + | x `equivalentSmall` 0 = 0 + | x <= 0 = -1 + | otherwise = 1 + +-- | 'nearSignum' specialized to Integer. +nearSignnumI :: forall a. (SmallishNum a, Num a, Ord a) => a -> Integer +nearSignnumI x + | x `near` 0 = 0 + | x <= 0 = -1 + | otherwise = 1 diff --git a/Immutaball/Share/Math/X3D.hs b/Immutaball/Share/Math/X3D.hs --- a/Immutaball/Share/Math/X3D.hs +++ b/Immutaball/Share/Math/X3D.hs @@ -6,6 +6,7 @@ {-# LANGUAGE Haskell2010 #-} {-# LANGUAGE TemplateHaskell, DerivingVia, ScopedTypeVariables #-} +{-# LANGUAGE FlexibleInstances, UndecidableInstances #-} -- SmallishInfiniteLineThreshold -- | Dependent types might make for a funner linear algebra implementation, so -- I just stick with what's most applicable for our uses and goals here. @@ -37,12 +38,17 @@ line3AxisReflectPlane3, line3Lerp, + smallishInfiniteLineThresholdd, + smallishInfiniteLineThresholdf, + SmallishInfiniteLineThreshold(..), line3CoordAtDistancePlane3, + line3PlaneIntersection, line3PointCoord, line3PointDistance, line3DistanceCoordFromPoint, line3Line3ClosestCoords, + line3Line3ClosestCoordsAny, line3Line3Distance, eqPlane3, @@ -55,6 +61,8 @@ nearPlane3PointsOnly, nearLine3PointsOnly, + plane3Plane3, + QCurve3(..), a2q3, a1q3, a0q3, qcurve3, qcurvePath3, @@ -70,6 +78,7 @@ import Control.Lens import Immutaball.Share.Math.Core +import Immutaball.Share.Utils -- | Normal, distance. -- @@ -326,6 +335,17 @@ line3Lerp :: forall a. (Num a) => Line3 a -> a -> Vec3 a line3Lerp l x = (l^.ol3) `pv3` (x `sv3` (l^.a0l3)) +smallishInfiniteLineThresholdd :: Double +smallishInfiniteLineThresholdd = 0.001 + +smallishInfiniteLineThresholdf :: Float +smallishInfiniteLineThresholdf = 0.001 + +class SmallishInfiniteLineThreshold a where smallishInfiniteLineThreshold :: a +instance {-# OVERLAPPING #-} SmallishInfiniteLineThreshold Double where smallishInfiniteLineThreshold = smallishInfiniteLineThresholdd +instance {-# OVERLAPPING #-} SmallishInfiniteLineThreshold Float where smallishInfiniteLineThreshold = smallishInfiniteLineThresholdf +instance {-# OVERLAPPABLE #-} (Fractional a) => SmallishInfiniteLineThreshold a where smallishInfiniteLineThreshold = realToFrac $ smallishInfiniteLineThresholdf + -- | Given a plane, find the 1D coord that projects onto the line, that finds -- the point at the given distance from the plane. i.e. for a line and plane, -- find x such that p0 + p1*x gives a point equal to distance d from the plane @@ -334,6 +354,10 @@ -- -- Conveniently, the change in distance from the plane per change in x is -- constant. +-- +-- Beware the sign of the distance. +-- +-- This is better suited for lines with non-trivial length. See 'SmallishInfiniteLineThreshold'. line3CoordAtDistancePlane3 :: forall a. (SmallNum a, Ord a, Num a, Fractional a) => Plane3 a -> Line3 a -> a -> Maybe a line3CoordAtDistancePlane3 p l d | dd_dx `equivalentSmall` 0 = Nothing @@ -347,6 +371,12 @@ p0d = plane3PointDistance p (l^.p0l3) p1d = plane3PointDistance p (l^.p1l3) +-- | Find the point on the plane where an infinite line intersects. +-- +-- This is better suited for lines with non-trivial length. See 'SmallishInfiniteLineThreshold'. +line3PlaneIntersection :: forall a. (SmallNum a, Ord a, Num a, Fractional a) => Line3 a -> Plane3 a -> Maybe (Vec3 a) +line3PlaneIntersection l p = line3Lerp l <$> line3CoordAtDistancePlane3 p l 0 + -- | Find the coord on the line to the closest point on that line to the given -- point in 3D space. -- @@ -387,7 +417,8 @@ line3DistanceCoordFromPoint l v distance = (sqrt $ sqx distance - sqx (line3PointDistance l v)) / (l^.a0l3.r3) -- | Given lines la and lb, find coords ‘ax’ and ‘bx’ on la and on lb --- representing the points at which the two lines are closest to each other. +-- representing the points at which the two infinite lines are closest to each +-- other. -- -- (Paralleling the order, the first coord is on the first line, and the second -- coord is on the second line.) @@ -478,7 +509,23 @@ bx = line3PointCoord lb $ line3Lerp la ax --- | Find the (closest) distance between 2 lines. +-- | Like 'line3Line3ClosestCoords', but if the lines are parallel, such that +-- there are infinitely many close points, pick as an arbitrary point la at +-- coord ax=0, and lb at the closest point. +line3Line3ClosestCoordsAny :: forall a. (Show a, SmallNum a, Fractional a, RealFloat a) => Line3 a -> Line3 a -> (a, a) +line3Line3ClosestCoordsAny la lb + | Just (ax, bx) <- line3Line3ClosestCoords la lb + {- + , not (isNaN ax || isInfinite ax) + , not (isNaN bx || isInfinite bx) = + -} = + (ax, bx) + | otherwise = + let ax = 0.0 in + let bx = line3PointCoord lb $ line3Lerp la ax in + (ax, bx) + +-- | Find the (closest) distance between 2 infinite lines. line3Line3Distance :: forall a. (Show a, SmallNum a, Fractional a, RealFloat a) => Line3 a -> Line3 a -> a line3Line3Distance la lb = case line3Line3ClosestCoords la lb of Nothing -> line3PointDistance la $ line3Lerp lb 0 @@ -499,7 +546,8 @@ nearLine3 a b = (a^.p0l3) `near3` (b^.p0l3) && (a^.p1l3) `near3` (b^.p1l3) -- These equivalence variants check the points only; you can e.g. use --- ‘negatePlaneOrientation’ and preserve equivalence. +-- ‘negatePlaneOrientation’ and preserve equivalence. (That is, flipping the +-- plane normal doesn't necessarily change which points are on the plane.) eqPlane3PointsOnly :: (SmallNum a, Ord a, Num a, RealFloat a) => Plane3 a -> Plane3 a -> Bool eqPlane3PointsOnly a b = let a' = negatePlaneOrientation a in (a^.unPlane3) `eq4` (b^.unPlane3) || (a'^.unPlane3) `eq4` (b^.unPlane3) @@ -514,6 +562,28 @@ nearLine3PointsOnly :: (SmallishNum a, Ord a, Num a, RealFloat a) => Line3 a -> Line3 a -> Bool nearLine3PointsOnly a b = let na' = na & (a0l3 %~ negate) in ( (na^.p0l3) `near3` (nb^.p0l3) && (na^.p1l3) `near3` (nb^.p1l3) ) || ( (na'^.p0l3) `near3` (nb^.p0l3) && (na'^.p1l3) `near3` (nb^.p1l3) ) where (na, nb) = let standardize = (a0l3 %~ v3normalize) . line3NormalizeDisplacement in (standardize a, standardize b) + +-- | Find the the line where 2 planes intersect, if they are not parallel. +plane3Plane3 :: (Num a, RealFloat a, Floating a, Ord a, SmallNum a) => Plane3 a -> Plane3 a -> Maybe (Line3 a) +plane3Plane3 pa pb = do + -- Get a0, the axis of the line, from the cross product of the 2 plane + -- normals. + let a0Dir = (pa^.abcp3) `vx3` (pb^.abcp3) + let a0DirUnit = v3or $ v3normalize a0Dir + a0 <- if' (min (a0Dir^.r3) (a0DirUnit^.r3) <= smallNum) Nothing $ Just a0DirUnit + + -- To find any point where the planes intersect, take a point on pa, make a + -- line from it using pa's normal cross a0, and find where this line + -- intersects pb. Use this arbitrary origin as an arbitrary point on the + -- line, and then normalize the displacement so that it's a common form. + let pap = pointToPlane zv3 pa -- Closest point on pa to the origin. + let lab = line3Axes pap ((pa^.abcp3) `vx3` a0) -- Line from pap to some point on the line. + lp0 <- line3PlaneIntersection lab pb -- An arbitrary point where pa intersects pb. + + let lPrenormalized = line3Axes lp0 a0 + let l = line3NormalizeDisplacement lPrenormalized + + return $ l -- | The curve represented by p = 1/2 (x^2) a2 + x a1 + a0 -- (The 1/2 comes from integrating twice.) diff --git a/Immutaball/Share/Utils.hs b/Immutaball/Share/Utils.hs --- a/Immutaball/Share/Utils.hs +++ b/Immutaball/Share/Utils.hs @@ -6,6 +6,7 @@ {-# LANGUAGE Haskell2010 #-} {-# LANGUAGE TemplateHaskell, UndecidableInstances, DerivingVia #-} +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} -- For 'FakeEOS'. module Immutaball.Share.Utils ( @@ -46,9 +47,22 @@ falseAsIntegral, deconsMaybe, - morElse + morElse, --AssumeEOS, + + setMapFilter, + steppingMean, + + FakeEOS(..), fakeEOS, + + modfl, + + uncurry3, + listOthers, + + runListT, + liftList ) where import Prelude () @@ -59,8 +73,11 @@ import Data.Functor.Compose import Data.List import Data.Maybe +import qualified Data.Set as S import Control.Lens +import qualified Pipes as P +import qualified Pipes.Prelude as P -- | See F-algebras and catamorphisms for the idiom. newtype Fixed f = Fixed {_fixed :: f (Fixed f)} @@ -209,3 +226,54 @@ instance Ord (AssumeEOS a) where _ <= _ = True instance Show (AssumeEOS a) where show _ = "(AssumeEOS)" -} + +setMapFilter :: (Ord a, Ord b) => (a -> Maybe b) -> S.Set a -> S.Set b +setMapFilter f s = + S.map (\x -> case x of + Nothing -> error "Internal error: setMapFilter found a Nothing after removing all Nothings." + Just a -> a) . + S.filter (\x -> case x of + Nothing -> False + Just _ -> True) . + S.map f $ + s + +-- | Find the mean value. +-- +-- (lastLen*lastMean + x)/(lastLen + 1) +-- = (lastLen/(lastLen + 1))*lastMean + x/(lastLen + 1) +steppingMean :: (Foldable t, Num a, Fractional a) => t a -> a +steppingMean = snd . foldr (\x (lastLen, lastMean) -> let lastLenP1 = lastLen + 1 in (lastLenP1, (lastLen/lastLenP1)*lastMean + x/lastLenP1)) (0, 0) + +-- | Considers all functions equal. Compiler record lookup obtains a different +-- record for Eq, Ord, Show instance values. +newtype FakeEOS a = FakeEOS { _fakeEOS :: a } +makeLenses ''FakeEOS +instance Eq (FakeEOS a) where _ == _ = True +instance Ord (FakeEOS a) where _ <= _ = True +instance Show (FakeEOS a) where show _ = "(FakeEOS)" + +-- | 'mod' generalized to Double and floats. +modfl :: (RealFrac a) => a -> a -> a +modfl a b = a - b*(fromInteger . floor $ a/b) + +-- | 3-ary 'uncurry'. +uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d +uncurry3 f (a, b, c) = f a b c + +-- | Given e.g. a list [1,2,3], return [(1,[2,3]), (2,[1,3]), (3,[1,2])]. +listOthers :: [a] -> [(a, [a])] +listOthers [] = [] +listOthers (x:xs) = (x,xs) : fmap (second (x:)) (listOthers xs) + +-- | Run a ListT monad. +-- +-- ListT is provided by the ‘pipes’ package. +runListT :: (Monad m) => P.ListT m a -> m [a] +runListT (P.Select m) = P.toListM m + +-- | Lift a plain list to a ListT monad. +-- +-- ListT is provided by the ‘pipes’ package. +liftList :: (Functor m) => [a] -> P.ListT m a +liftList = P.Select . P.each diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -1,6 +1,7 @@ #!/usr/bin/env -S bash -c 'eval "$(cat "$0" | head -n+3 | tail -n+3 | tail -c+3)" "$0" "${@@Q}"' {- -#!/usr/bin/env -S runhaskell '-package containers' '-package bytestring' '-package transformers' '-package pipes' '-package lens' '-package parallel' '-package stm' '-package async' '-package wires' '-package mtl' '-package filepath' '-package directory' '-package prettyprinter' '-package parsec' '-package unbounded-delays' '-package time' '-package sdl2' '-package gl' '-package array' '-package OpenGL' '-package sdl2-ttf' '-package libvorbis' '-package JuicyPixels' '-package curl' '-package i18n' '-package text' +#!/usr/bin/env -S runhaskell '-i.:./dependency-substitutions/wires-nofallback-meta' '-package containers' '-package bytestring' '-package transformers' '-package pipes' '-package lens' '-package parallel' '-package stm' '-package async' '-package wires' '-package mtl' '-package filepath' '-package directory' '-package prettyprinter' '-package parsec' '-package unbounded-delays' '-package time' '-package sdl2' '-package gl' '-package array' '-package OpenGL' '-package sdl2-ttf' '-package libvorbis' '-package JuicyPixels' '-package curl' '-package i18n' '-package text' +#!/usr/bin/env -S runhaskell '-i.:./dependency-substitutions/wires-fallback-meta' '-package containers' '-package bytestring' '-package transformers' '-package pipes' '-package lens' '-package parallel' '-package stm' '-package async' '-package mtl' '-package filepath' '-package directory' '-package prettyprinter' '-package parsec' '-package unbounded-delays' '-package time' '-package sdl2' '-package gl' '-package array' '-package OpenGL' '-package sdl2-ttf' '-package libvorbis' '-package JuicyPixels' '-package curl' '-package i18n' '-package text' -} {-# OPTIONS_GHC -fno-warn-tabs #-} -- Support tab indentation better, for a better default of no warning if tabs are used: https://dmitryfrank.com/articles/indent_with_tabs_align_with_spaces . -- Enable warnings: diff --git a/NOTES-building-dependencies.md b/NOTES-building-dependencies.md new file mode 100644 --- /dev/null +++ b/NOTES-building-dependencies.md @@ -0,0 +1,97 @@ +# Building dependencies + +Immutaball now can provide its own fallback implementation if the wires +dependency fails to build, with its own internal rewrite of the FRP library. + +As of this writing, the latest wires package on Hackage is out-of-date with the +most recent versions of its dependencies on Hackage, so it will fail to build +without local modifications, until a new, up-to-date version is submitted to +Hackage. + +However, if you still wish to build wires locally so that Immutaball can use it +as an external dependency, here are my old build notes on changes that can get +it to build with up-to-date dependencies. + +## Build notes + +### wires 0.2.1 + +As of 2024-09-27, the latest wires dependency, v0.2.1, is a little out of date. +Simply building a new local version e.g. v0.2.1.0.1, with updated dependency +upper bounds with a new semialign dependency with the following changes is +sufficient to build wires. + +Thus this package depends on wires > v0.2.1. + +To ensure that wires has consistent dependencies with this package, I recommend +you copy the build-deps from this package and append them to your local wires +source package, and then manually install the local wires source package by +running ‘cabal install --lib’ inside your git clone (this adds to the user +cabal store and updates e.g. `~/.ghc/x86_64-linux-9.4.2/environments/default`), +with the changes mentioned, including increasing the upper bounds of ‘wires’'s +existing dependencies (see ‘New Dependencies’). Otherwise when building this +package, local packages such as your locally install ‘wires’ would be fixed to +the dependencies chosen when you built it, which may be incompatible with this +package's dependencies. + +Old build tips: + +(You may build it with ‘cabal install --lib --package-env=./package-env.txt’, +looking for the package-db path inside ./package-env.txt afterwards, and then +building immutaball with e.g. +‘cabal build --package-db=~/.local/state/cabal/store/ghc-9.4.2/package.db’) + +(You may also consider manually installing all deps with ‘cabal install --lib +dep’ before building old deps like wires, to help it pick recent versions of +dependencies, without later failing to choose newer dependencies because wires +was earlier built with older dependencies and must be re-built. Alternatively, +comment out ‘wires’ from the .cabal file, run cabal build so it builds the +dependencies except for ‘wires’, and then uncomment ‘wires’.) + +(Finally, adding a ‘text >= 2.1.1 && < 2.2’ version to ‘wires’ before installing +it with ‘cabal install --lib’ inside the git clone may help cabal build this +package. Additionally, you can even copy this package's dependencies and append them to +wires' dependencies to ensure the dependencies are consistent.) + +#### Semialign change + +In Control/Wires/Internal.hs, replace + +``` +instance Align Event where + nil = NotNow +``` + +with + +``` +instance Align Event where + nil = NotNow +instance Semialign Event where +``` + +#### Utils change + +In Control/Wires/Utils.hs, replace + +``` +import Data.These +``` + +with + +``` +import Data.These.Combinators +``` + +#### New dependencies + +``` +base >= 4.8 && < 5, +deepseq >= 1.4.0 && < 1.7, +mtl >= 2.0 && < 5.7, +profunctors >= 5.0 && < 5.7, +semigroupoids >= 5.0 && < 6.1, +these >= 0.7.0 && < 1.3, +semialign >= 1.3.1 && < 1.4 +``` diff --git a/Putt.hs b/Putt.hs --- a/Putt.hs +++ b/Putt.hs @@ -1,6 +1,7 @@ #!/usr/bin/env -S bash -c 'eval "$(cat "$0" | head -n+3 | tail -n+3 | tail -c+3)" "$0" "${@@Q}"' {- -#!/usr/bin/env -S runhaskell '-package containers' '-package bytestring' '-package transformers' '-package pipes' '-package lens' '-package parallel' '-package stm' '-package async' '-package wires' '-package mtl' '-package filepath' '-package directory' '-package prettyprinter' '-package parsec' '-package unbounded-delays' '-package time' '-package sdl2' '-package gl' '-package array' '-package OpenGL' '-package sdl2-ttf' '-package libvorbis' '-package JuicyPixels' '-package curl' '-package i18n' '-package text' +#!/usr/bin/env -S runhaskell '-i.:./dependency-substitutions/wires-nofallback-meta' '-package containers' '-package bytestring' '-package transformers' '-package pipes' '-package lens' '-package parallel' '-package stm' '-package async' '-package wires' '-package mtl' '-package filepath' '-package directory' '-package prettyprinter' '-package parsec' '-package unbounded-delays' '-package time' '-package sdl2' '-package gl' '-package array' '-package OpenGL' '-package sdl2-ttf' '-package libvorbis' '-package JuicyPixels' '-package curl' '-package i18n' '-package text' +#!/usr/bin/env -S runhaskell '-i.:./dependency-substitutions/wires-fallback-meta' '-package containers' '-package bytestring' '-package transformers' '-package pipes' '-package lens' '-package parallel' '-package stm' '-package async' '-package mtl' '-package filepath' '-package directory' '-package prettyprinter' '-package parsec' '-package unbounded-delays' '-package time' '-package sdl2' '-package gl' '-package array' '-package OpenGL' '-package sdl2-ttf' '-package libvorbis' '-package JuicyPixels' '-package curl' '-package i18n' '-package text' -} {-# OPTIONS_GHC -fno-warn-tabs #-} -- Support tab indentation better, for a better default of no warning if tabs are used: https://dmitryfrank.com/articles/indent_with_tabs_align_with_spaces . -- Enable warnings: diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,14 +1,10 @@ # Prototype Currently this project only implements basic parts of the game: minimal GUI, -basic physics, and a renderer. Much of the game is currently unimplemented -(audio, goals, moving bodies, gameplay mechanics, a more efficient physics -implementation), but this project still serves as a useful example of a purely -functional FRP application. - -Currently the physics does not apply BSP partitioning but brute force checks -collisions with every body in the level each frame. Larger levels can't handle -this, but many of the levels in the first three level sets are playable. +basic physics, and a basic renderer. Much of the game is currently +unimplemented (audio, goals, complete moving body physics, gameplay mechanics, +etc.), but this project still serves as a useful example of a purely functional +FRP application. Currently the physics has a few bugs. # Immutaball @@ -21,95 +17,13 @@ ![screenshot: readme-screenshot0-v0.1.0.1.png](doc/screenshots/readme-screenshot0-v0.1.0.1.png) -Demo video: - -## Build notes - -### wires 0.2.1 - -As of 2024-09-27, the latest wires dependency, v0.2.1, is a little out of date. -Simply building a new local version e.g. v0.2.1.0.1, with updated dependency -upper bounds with a new semialign dependency with the following changes is -sufficient to build wires. - -Thus this package depends on wires > v0.2.1. - -To ensure that wires has consistent dependencies with this package, I recommend -you copy the build-deps from this package and append them to your local wires -source package, and then manually install the local wires source package by -running ‘cabal install --lib’ inside your git clone (this adds to the user -cabal store and updates e.g. `~/.ghc/x86_64-linux-9.4.2/environments/default`), -with the changes mentioned, including increasing the upper bounds of ‘wires’'s -existing dependencies (see ‘New Dependencies’). Otherwise when building this -package, local packages such as your locally install ‘wires’ would be fixed to -the dependencies chosen when you built it, which may be incompatible with this -package's dependencies. - -Old build tips: - -(You may build it with ‘cabal install --lib --package-env=./package-env.txt’, -looking for the package-db path inside ./package-env.txt afterwards, and then -building immutaball with e.g. -‘cabal build --package-db=~/.local/state/cabal/store/ghc-9.4.2/package.db’) - -(You may also consider manually installing all deps with ‘cabal install --lib -dep’ before building old deps like wires, to help it pick recent versions of -dependencies, without later failing to choose newer dependencies because wires -was earlier built with older dependencies and must be re-built. Alternatively, -comment out ‘wires’ from the .cabal file, run cabal build so it builds the -dependencies except for ‘wires’, and then uncomment ‘wires’.) - -(Finally, adding a ‘text >= 2.1.1 && < 2.2’ version to ‘wires’ before installing -it with ‘cabal install --lib’ inside the git clone may help cabal build this -package. Additionally, you can even copy this package's dependencies and append them to -wires' dependencies to ensure the dependencies are consistent.) - -#### Semialign change - -In Control/Wires/Internal.hs, replace - -``` -instance Align Event where - nil = NotNow -``` - -with - -``` -instance Align Event where - nil = NotNow -instance Semialign Event where -``` - -#### Utils change - -In Control/Wires/Utils.hs, replace - -``` -import Data.These -``` - -with - -``` -import Data.These.Combinators -``` - -#### New dependencies - -``` -base >= 4.8 && < 5, -deepseq >= 1.4.0 && < 1.7, -mtl >= 2.0 && < 5.7, -profunctors >= 5.0 && < 5.7, -semigroupoids >= 5.0 && < 6.1, -these >= 0.7.0 && < 1.3, -semialign >= 1.3.1 && < 1.4 -``` +Demo video: . +(Demo recorded before BSP physics algorithm.) ## Usage example ``` -(cd -- "${HOME}/git/neverball" && make -j7) # build neverball -cabal run --package-db="${HOME}/.local/state/cabal/store/ghc-9.13.20240927/package.db" immutaball -- -d ~/git/neverball/data +(cd -- "${HOME}/git" && git clone https://github.com/Neverball/neverball) # clone neverball +(cd -- "${HOME}/git/neverball" && make -j7) # build neverball +cabal run immutaball -- -d ~/git/neverball/data # run immutaball ``` diff --git a/Test.hs b/Test.hs --- a/Test.hs +++ b/Test.hs @@ -1,6 +1,7 @@ #!/usr/bin/env -S bash -c 'eval "$(cat "$0" | head -n+3 | tail -n+3 | tail -c+3)" "$0" "${@@Q}"' {- -#!/usr/bin/env -S runhaskell '-package containers' '-package bytestring' '-package transformers' '-package pipes' '-package lens' '-package parallel' '-package stm' '-package async' '-package wires' '-package mtl' '-package filepath' '-package directory' '-package prettyprinter' '-package parsec' '-package unbounded-delays' '-package time' '-package sdl2' '-package gl' '-package array' '-package OpenGL' '-package sdl2-ttf' '-package libvorbis' '-package JuicyPixels' '-package curl' '-package i18n' '-package text' '-package tasty' '-package tasty-hunit' '-package tasty-quickcheck' '-package HUnit' '-package QuickCheck' +#!/usr/bin/env -S runhaskell '-i.:./dependency-substitutions/wires-nofallback-meta' '-package containers' '-package bytestring' '-package transformers' '-package pipes' '-package lens' '-package parallel' '-package stm' '-package async' '-package wires' '-package mtl' '-package filepath' '-package directory' '-package prettyprinter' '-package parsec' '-package unbounded-delays' '-package time' '-package sdl2' '-package gl' '-package array' '-package OpenGL' '-package sdl2-ttf' '-package libvorbis' '-package JuicyPixels' '-package curl' '-package i18n' '-package text' '-package tasty' '-package tasty-hunit' '-package tasty-quickcheck' '-package HUnit' '-package QuickCheck' +#!/usr/bin/env -S runhaskell '-i.:./dependency-substitutions/wires-fallback-meta' '-package containers' '-package bytestring' '-package transformers' '-package pipes' '-package lens' '-package parallel' '-package stm' '-package async' '-package mtl' '-package filepath' '-package directory' '-package prettyprinter' '-package parsec' '-package unbounded-delays' '-package time' '-package sdl2' '-package gl' '-package array' '-package OpenGL' '-package sdl2-ttf' '-package libvorbis' '-package JuicyPixels' '-package curl' '-package i18n' '-package text' '-package tasty' '-package tasty-hunit' '-package tasty-quickcheck' '-package HUnit' '-package QuickCheck' -} {-# OPTIONS_GHC -fno-warn-tabs #-} -- Support tab indentation better, for a better default of no warning if tabs are used: https://dmitryfrank.com/articles/indent_with_tabs_align_with_spaces . -- Enable warnings: diff --git a/Test/Data/LabeledBinTree/Orphans.hs b/Test/Data/LabeledBinTree/Orphans.hs new file mode 100644 --- /dev/null +++ b/Test/Data/LabeledBinTree/Orphans.hs @@ -0,0 +1,45 @@ +{-# OPTIONS_GHC -fno-warn-tabs #-} -- Support tab indentation better, for a better default of no warning if tabs are used: https://dmitryfrank.com/articles/indent_with_tabs_align_with_spaces . +-- Enable warnings: +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +-- Orphans.hs. + +{-# LANGUAGE Haskell2010 #-} +{-# LANGUAGE TemplateHaskell #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +module Test.Data.LabeledBinTree.Orphans + ( + ) where + +import Prelude () +import Immutaball.Prelude + +import Data.Function hiding (id, (.)) + +import Test.QuickCheck + +import Data.LabeledBinTree +import Immutaball.Share.Utils + +instance (Arbitrary a) => Arbitrary (LabeledBinTree a) where + -- | Styled as recommended in the QuickCheck manual. + arbitrary = sized . fix $ \tree -> \size -> let subtree = tree (size `div` 2) in + if' (size <= 0) (pure emptyLBT) . + if' (size == 1) (leafLBT <$> arbitrary) . + oneof $ [ + pure emptyLBT, + leafLBT <$> arbitrary, + forkLBT <$> subtree <*> arbitrary <*> subtree + ] + shrink = deconsLabeledBinTree + [] + (\_a -> [emptyLBT]) + (\l a r -> concat + [ + [emptyLBT], + [l, r], + [forkLBT l' a' r' | (l', a', r') <- shrink (l, a, r)] + ] + ) diff --git a/Test/Data/LabeledBinTree/Test.hs b/Test/Data/LabeledBinTree/Test.hs new file mode 100644 --- /dev/null +++ b/Test/Data/LabeledBinTree/Test.hs @@ -0,0 +1,79 @@ +{-# OPTIONS_GHC -fno-warn-tabs #-} -- Support tab indentation better, for a better default of no warning if tabs are used: https://dmitryfrank.com/articles/indent_with_tabs_align_with_spaces . +-- Enable warnings: +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +-- Test.hs. + +{-# LANGUAGE Haskell2010 #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Test.Data.LabeledBinTree.Test + ( + main, + testsMain, + tests, + + simpleConstant + ) where + +--import Control.Arrow +--import Data.Functor.Identity + +--import Control.Lens +import Control.Monad +import Test.HUnit +--import Test.QuickCheck +import Test.Tasty +import Test.Tasty.HUnit hiding ((@?=), assertBool) +import Test.Tasty.QuickCheck + +import Data.LabeledBinTree +import Test.Data.LabeledBinTree.Orphans () + +main :: IO () +main = testsMain + +testsMain :: IO () +testsMain = defaultMain tests + +simpleConstant :: Integer +simpleConstant = 3 + +tests :: TestTree +tests = testGroup "Data.LabeledBinTree" $ + [ + testCase "simpleConstant == 3" $ + simpleConstant @?= 3, + + -- I think it grows exponentionally (although I haven't rigorously + -- worked out the tight big theta growth class for space if everything + -- were strictly evaluated), so when testing for associativity, we'll + -- want to limit the size of trees, since we're not just taking a + -- single path or a select set of paths. e.g. I saw maxTreeSizeSum of + -- 3*8 (average size of 8) result in a tree size of 443,621. + testGroup "testing monadic associativity of Tree" $ + let maxTreeSizeSum = 3*6 in -- See above; probably exponential growth, and we're not traversing a single path but the entire tree. + [ + testProperty "monadic associativity test of Tree 0" $ + \(int :: Integer) -> + \(fints :: LabeledBinTree Integer) -> + \(gints :: LabeledBinTree Integer) -> + \(hints :: LabeledBinTree Integer) -> + (sum $ numAnyDirectLBTI <$> [fints, gints, hints]) <= maxTreeSizeSum ==> -- This seems to stop what might be intermittent size explotions. + let f = \y -> (\x -> x + y) <$> fints in + let g = \y -> (\x -> x + y) <$> gints in + let h = \y -> (\x -> x + y) <$> hints in + ( (f <=< g) <=< h ) int `eqLBT` ( f <=< (g <=< h) ) int, + + testProperty "monadic associativity test of Tree 0, but with strict equality" $ + \(int :: Integer) -> + \(fints :: LabeledBinTree Integer) -> + \(gints :: LabeledBinTree Integer) -> + \(hints :: LabeledBinTree Integer) -> + (sum $ numAnyDirectLBTI <$> [fints, gints, hints]) <= maxTreeSizeSum ==> -- This seems to stop what might be intermittent size explotions. + let f = \y -> (\x -> x + y) <$> fints in + let g = \y -> (\x -> x + y) <$> gints in + let h = \y -> (\x -> x + y) <$> hints in + ( (f <=< g) <=< h ) int == ( f <=< (g <=< h) ) int + ] + ] diff --git a/Test/Immutaball/Share/Math/X3D/Test.hs b/Test/Immutaball/Share/Math/X3D/Test.hs --- a/Test/Immutaball/Share/Math/X3D/Test.hs +++ b/Test/Immutaball/Share/Math/X3D/Test.hs @@ -5,6 +5,7 @@ -- Test.hs. {-# LANGUAGE Haskell2010 #-} +{-# LANGUAGE ScopedTypeVariables #-} module Test.Immutaball.Share.Math.X3D.Test ( @@ -15,7 +16,8 @@ simpleConstant, sampleLine0, sampleLine1, - planeX1 + planeX1, + planeZ2 ) where --import Control.Arrow @@ -26,9 +28,10 @@ --import Test.QuickCheck import Test.Tasty import Test.Tasty.HUnit hiding ((@?=), assertBool) ---import Test.Tasty.QuickCheck +import Test.Tasty.QuickCheck import Immutaball.Share.Math +import Immutaball.Share.Utils import Test.Immutaball.Share.Math.Core.Orphans () main :: IO () @@ -49,6 +52,9 @@ planeX1 :: Plane3 Double planeX1 = normalPlane3 (Vec3 1 0 0) 1 +planeZ2 :: Plane3 Double +planeZ2 = normalPlane3 (Vec3 0 0 1) 2 + tests :: TestTree tests = testGroup "Immutaball.Share.Math.X3D" $ [ @@ -64,9 +70,31 @@ testGroup "pointToPlane" $ [ testCase "simple sample test" $ - (Vec3 7 (-4) 88 `pointToPlane` planeX1) `eq3` Vec3 1 (-4) 88 @?= True + (Vec3 7 (-4) 88 `pointToPlane` planeX1) `eq3` Vec3 1 (-4) 88 @?= True, + testProperty "the closest point on a random plane to the origin matches its normal and distance" $ + -- Get a random plane. + \(pabcRaw :: Vec3 Double) -> + \(pd :: Double ) -> + let pabc = v3normalize pabcRaw & \v -> if' (not $ (v^.r3) `near` 1.0) (Vec3 1.0 0.0 0.0) $ v in + let plane = normalPlane3 pabc pd in + + let p = pointToPlane zv3 plane in + p `near3` ((plane^.dp3) `sv3` (plane^.abcp3)) ], + testGroup "line3PlaneIntersection" $ + [ + testProperty "a random plane's normal intersects the plane at the closest point on the plane to the origin" $ + -- Get a random plane. + \(pabcRaw :: Vec3 Double) -> + \(pd :: Double ) -> + let pabc = v3normalize pabcRaw & \v -> if' (not $ (v^.r3) `near` 1.0) (Vec3 1.0 0.0 0.0) $ v in + let plane = normalPlane3 pabc pd in + + let p = pointToPlane zv3 plane in + (pure near3 <*> line3PlaneIntersection (line3Axes zv3 (plane^.abcp3)) plane <*> pure p) == Just True + ], + testGroup "plane3ReflectPoint" $ [ testCase "simple sample test" $ @@ -130,5 +158,41 @@ line3Line3Distance sampleLine0 sampleLine1 `equivalentSmall` 1 @?= True, testCase "sample lines are distance 1 with second z-negated" $ line3Line3Distance sampleLine0 (sampleLine1 & ol3.z3 %~ negate) `equivalentSmall` 1 @?= True + ], + + testGroup "plane3 plane3 tests" $ + [ + testCase "planeX1 planeZ2 intersects at" $ + let allowOtherDirection = False in + ((pure nearLine3 <*> plane3Plane3 planeX1 planeZ2 <*> pure (line3Points (Vec3 1 0 2) (Vec3 1 (-1) 2))) == Just True) || + ((pure nearLine3 <*> plane3Plane3 planeX1 planeZ2 <*> pure (line3Points (Vec3 1 0 2) (Vec3 1 1 2))) == Just True && allowOtherDirection) @?= True, + testProperty "planes intersect with points on both planes" $ + -- Get 2 random planes, pa and pb. + \(paabcRaw :: Vec3 Double) -> + \(pbabcRaw :: Vec3 Double) -> + \(pad :: Double ) -> + \(pbd :: Double ) -> + \(lx :: Double ) -> + let paabc = v3normalize paabcRaw & \v -> if' (not $ (v^.r3) `near` 1.0) (Vec3 1.0 0.0 0.0) $ v in + let pbabc = v3normalize pbabcRaw & \v -> if' (not $ (v^.r3) `near` 1.0) (Vec3 1.0 0.0 0.0) $ v in + let pa = normalPlane3 paabc pad in + let pb = normalPlane3 pbabc pbd in + + -- Get their intersection. + let ml = plane3Plane3 pa pb in + case ml of + Nothing -> + -- They don't intersect; make sure the cross + -- product of the 2 normals are smallish. + let cross = (pa^.abcp3) `vx3` (pb^.abcp3) in + cross^.r3 <= smallishNum + Just l -> + -- Get a random point on the intersection line. + let p = line3Lerp l lx in + + -- Make sure it's on pa. + plane3PointDistance pa p `near` 0 && + -- Make sure it's on pb. + plane3PointDistance pb p `near` 0 ] ] diff --git a/Test/Immutaball/Test.hs b/Test/Immutaball/Test.hs --- a/Test/Immutaball/Test.hs +++ b/Test/Immutaball/Test.hs @@ -19,6 +19,7 @@ --import Test.Tasty.HUnit hiding ((@?=), assertBool) --import Test.Tasty.QuickCheck +import qualified Test.Data.LabeledBinTree.Test import qualified Test.Immutaball.Share.Math.Test import qualified Test.Immutaball.Share.State.Test import qualified Test.Immutaball.Share.Wire.Test @@ -32,6 +33,7 @@ tests :: Bool -> TestTree tests headless = testGroup "Immutaball" $ [ + Test.Data.LabeledBinTree.Test.tests, Test.Immutaball.Share.Wire.Test.tests, Test.Immutaball.Share.State.Test.tests headless, Test.Immutaball.Share.Math.Test.tests diff --git a/dependency-substitutions/wires-fallback-meta/Control/Wire/Meta.hs b/dependency-substitutions/wires-fallback-meta/Control/Wire/Meta.hs new file mode 100644 --- /dev/null +++ b/dependency-substitutions/wires-fallback-meta/Control/Wire/Meta.hs @@ -0,0 +1,18 @@ +{-# OPTIONS_GHC -fno-warn-tabs #-} -- Support tab indentation better, for a better default of no warning if tabs are used: https://dmitryfrank.com/articles/indent_with_tabs_align_with_spaces . +-- Enable warnings: +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +-- Wire.hs. + +{-# LANGUAGE Haskell2010 #-} + +-- | Information about which Wire implementation is used. +module Control.Wire.Meta + ( + isFallbackWire + ) where + +-- | Is the fallback implementation used rather than the external ‘wires’ +-- dependency? +isFallbackWire :: Bool +isFallbackWire = True diff --git a/dependency-substitutions/wires-nofallback-meta/Control/Wire/Meta.hs b/dependency-substitutions/wires-nofallback-meta/Control/Wire/Meta.hs new file mode 100644 --- /dev/null +++ b/dependency-substitutions/wires-nofallback-meta/Control/Wire/Meta.hs @@ -0,0 +1,18 @@ +{-# OPTIONS_GHC -fno-warn-tabs #-} -- Support tab indentation better, for a better default of no warning if tabs are used: https://dmitryfrank.com/articles/indent_with_tabs_align_with_spaces . +-- Enable warnings: +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +-- Wire.hs. + +{-# LANGUAGE Haskell2010 #-} + +-- | Information about which Wire implementation is used. +module Control.Wire.Meta + ( + isFallbackWire + ) where + +-- | Is the fallback implementation used rather than the external ‘wires’ +-- dependency? +isFallbackWire :: Bool +isFallbackWire = False diff --git a/dependency-substitutions/wires/Control/Wire.hs b/dependency-substitutions/wires/Control/Wire.hs new file mode 100644 --- /dev/null +++ b/dependency-substitutions/wires/Control/Wire.hs @@ -0,0 +1,17 @@ +{-# OPTIONS_GHC -fno-warn-tabs #-} -- Support tab indentation better, for a better default of no warning if tabs are used: https://dmitryfrank.com/articles/indent_with_tabs_align_with_spaces . +-- Enable warnings: +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +-- Wire.hs. + +{-# LANGUAGE Haskell2010 #-} + +-- | A rewrite of wires, sufficient for our purposes. +module Control.Wire + ( + module Control.Wire.Controller, + module Control.Wire.Internal + ) where + +import Control.Wire.Controller +import Control.Wire.Internal diff --git a/dependency-substitutions/wires/Control/Wire/Controller.hs b/dependency-substitutions/wires/Control/Wire/Controller.hs new file mode 100644 --- /dev/null +++ b/dependency-substitutions/wires/Control/Wire/Controller.hs @@ -0,0 +1,15 @@ +{-# OPTIONS_GHC -fno-warn-tabs #-} -- Support tab indentation better, for a better default of no warning if tabs are used: https://dmitryfrank.com/articles/indent_with_tabs_align_with_spaces . +-- Enable warnings: +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +-- Wire/Conttroller.hs. + +{-# LANGUAGE Haskell2010 #-} + +-- | A rewrite of wires, sufficient for our purposes. +module Control.Wire.Controller + ( + module Control.Wire.Internal + ) where + +import Control.Wire.Internal diff --git a/dependency-substitutions/wires/Control/Wire/Internal.hs b/dependency-substitutions/wires/Control/Wire/Internal.hs new file mode 100644 --- /dev/null +++ b/dependency-substitutions/wires/Control/Wire/Internal.hs @@ -0,0 +1,62 @@ +{-# OPTIONS_GHC -fno-warn-tabs #-} -- Support tab indentation better, for a better default of no warning if tabs are used: https://dmitryfrank.com/articles/indent_with_tabs_align_with_spaces . +-- Enable warnings: +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +-- Wire/Internal.hs. + +{-# LANGUAGE Haskell2010 #-} +--{-# LANGUAGE TemplateHaskell, Arrows, DerivingVia, RankNTypes #-} + +-- | A rewrite of wires, sufficient for our purposes. +module Control.Wire.Internal + ( + Wire(..), + stepWire + ) where + +import Control.Arrow +import Control.Category as C +import Control.Monad.Fix + +-- | A self-modifying function. +-- +-- This is the central construct in the ‘wires’ FRP implementation. +newtype Wire m a b = Wire { _wireStep :: a -> m (b, Wire m a b) } + +-- | Step a wire. Obtain its result and the next version of itself. +{-# INLINE stepWire #-} +stepWire :: Wire m a b -> a -> m (b, Wire m a b) +stepWire = _wireStep + +instance (Functor m) => Functor (Wire m a) where + {-# INLINE fmap #-} + fmap f (Wire w) = Wire $ \a -> (\(b, w') -> (f b, fmap f w')) <$> w a + +instance (Applicative m) => Applicative (Wire m i) where + {-# INLINE pure #-} + pure a = fix $ \me -> Wire $ \_i -> pure (a, me) + {-# INLINE (<*>) #-} + (Wire wf) <*> (Wire wa) = Wire $ \i -> pure (\(f, wf') (a, wa') -> (f a, wf' <*> wa')) <*> wf i <*> wa i + +instance (Monad m) => Category (Wire m) where + {-# INLINE id #-} + id = fix $ \me -> Wire $ \a -> return (a, me) + {-# INLINE (.) #-} + (Wire wc) . (Wire wb) = Wire $ \a -> wb a >>= \(b, wb') -> wc b >>= \(c, wc') -> return (c, wc' C.. wb') + +instance (Monad m) => Arrow (Wire m) where + {-# INLINE arr #-} + arr f = fix $ \me -> Wire $ \a -> pure (f a, me) + {-# INLINE first #-} + first (Wire w) = Wire $ \(a, d) -> (\(b, w') -> ((b, d), first w')) <$> w a + +instance (Monad m) => ArrowChoice (Wire m) where + -- (Tricky: in the Left case, don't use ‘me’ which would discard ‘w'’.) + {-# INLINE left #-} + left (Wire w) = fix $ \me -> Wire $ \bd -> either (\b -> (\(c, w') -> (Left c, left w')) <$> w b) (\d -> pure (Right d, me)) bd + +instance (MonadFix m) => ArrowLoop (Wire m) where + -- w :: (b, d) -> m ((c, d), Wire m (b, d) (c, d)) + -- Make sure this is lazy enough, or it could hang! + {-# INLINE loop #-} + loop (Wire w) = Wire $ \b -> (\((c, _d), w') -> (c, loop w')) <$> (mfix $ \ ~(~(_c, d), _w') -> w (b, d)) diff --git a/immutaball-core.cabal b/immutaball-core.cabal --- a/immutaball-core.cabal +++ b/immutaball-core.cabal @@ -1,11 +1,12 @@ cabal-version: 3.0 name: immutaball-core -version: 0.1.0.4.1 +version: 0.1.0.5.1 -synopsis: Immutaball platformer game +synopsis: Immutaball platformer game (prototype version) description: The Immutaball platformer game is a rewrite of Neverball in Haskell. + (Prototype version.) category: Games homepage: https://nibzdil.org/ bug-reports: https://nibzdil.org/ @@ -17,11 +18,13 @@ author: Byron Johnson maintainer: bjohnson@nibzdil.org build-type: Simple -copyright: 2024, Byron Johnson +copyright: 2024-2025, Byron Johnson extra-source-files: README.md + NOTES-building-dependencies.md extra-doc-files: + CHANGELOG.md doc/legal/*.md doc/legal/*.txt doc/screenshots/*.png @@ -30,10 +33,10 @@ type: git location: https://github.com/nibzdil/immutaball -source-repository this - type: git - location: https://github.com/nibzdil/immutaball - tag: v0.1.0.4.1-hackage +--source-repository this +-- type: git +-- location: https://github.com/nibzdil/immutaball +-- tag: v0.1.0.0-dev flag add-default-compiler-flags description: @@ -41,6 +44,16 @@ default: True manual: True +flag internal-wires + description: + Instead of an external wires dependency, use an internal implementation + sufficient for this package. Useful since as of now, the latest + version on Hackage is not up-to-date with the latest versions of its + dependencies, so it would not build with this project without a + manually modified local build of this external dependency. + default: False + manual: False + common all-components default-language: Haskell2010 other-extensions: @@ -85,7 +98,7 @@ --stm >= 2.5.3.1 && < 2.6, stm >= 2.5.1.0 && < 2.6, async >= 2.2.5 && < 2.3, - wires > 0.2.1 && < 0.3, + --wires > 0.2.1 && < 0.3, mtl >= 2.2 && < 2.4, --filepath >= 1.5.3.0 && < 1.6, filepath >= 1.4.2.2 && < 1.6, @@ -107,14 +120,37 @@ i18n >= 0.4.0.0 && < 0.5, text >= 2.1 && < 2.2 + if !flag(internal-wires) + build-depends: + wires > 0.2.1 && < 0.3 + hs-source-dirs: + . + ./dependency-substitutions/wires-nofallback-meta + other-modules: + Control.Wire.Meta + else + hs-source-dirs: + . + ./dependency-substitutions/wires-fallback-meta + ./dependency-substitutions/wires + other-modules: + Control.Wire.Meta + other-modules: + Control.Wire + Control.Wire.Controller + Control.Wire.Internal + common executable-components build-depends: immutaball-core other-modules: Control.Monad.Trans.MaybeM + Data.LabeledBinTree Immutaball.Ball.CLI Immutaball.Ball.CLI.Config Immutaball.Ball.Game + Immutaball.Ball.Level + Immutaball.Ball.Level.Render Immutaball.Ball.LevelSets Immutaball.Ball.Main Immutaball.Ball.State.Game @@ -148,7 +184,6 @@ Immutaball.Share.Level.Analysis.LowLevel Immutaball.Share.Level.Attributes Immutaball.Share.Level.Base - Immutaball.Share.Level.Render Immutaball.Share.Level.Parser Immutaball.Share.Level.Utils Immutaball.Share.Math @@ -182,9 +217,12 @@ exposed-modules: Control.Monad.Trans.MaybeM + Data.LabeledBinTree Immutaball.Ball.CLI Immutaball.Ball.CLI.Config Immutaball.Ball.Game + Immutaball.Ball.Level + Immutaball.Ball.Level.Render Immutaball.Ball.LevelSets Immutaball.Ball.Main Immutaball.Ball.State.Game @@ -218,7 +256,6 @@ Immutaball.Share.Level.Analysis.LowLevel Immutaball.Share.Level.Attributes Immutaball.Share.Level.Base - Immutaball.Share.Level.Render Immutaball.Share.Level.Parser Immutaball.Share.Level.Utils Immutaball.Share.Math @@ -253,6 +290,8 @@ QuickCheck >= 2.15.0.1 && < 2.16 other-modules: + Test.Data.LabeledBinTree.Orphans + Test.Data.LabeledBinTree.Test Test.Immutaball.Test Test.Immutaball.Share.Math.Core.Orphans Test.Immutaball.Share.Math.Core.Test