packages feed

immutaball-core 0.1.0.4.1 → 0.1.0.5.1

raw patch · 33 files changed

+3963/−1329 lines, 33 files

Files

+ CHANGELOG.md view
@@ -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.
+ Data/LabeledBinTree.hs view
@@ -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
Immutaball/Ball/CLI.hs view
@@ -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 {
Immutaball/Ball/CLI/Config.hs view
@@ -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}
Immutaball/Ball/Game.hs view
@@ -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,
+ Immutaball/Ball/Level.hs view
@@ -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
+ Immutaball/Ball/Level/Render.hs view
@@ -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)
Immutaball/Ball/State/Game.hs view
@@ -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.
Immutaball/Ball/State/Play.hs view
@@ -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)
Immutaball/Putt/CLI.hs view
@@ -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
Immutaball/Share/Config.hs view
@@ -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
Immutaball/Share/Level.hs view
@@ -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
Immutaball/Share/Level/Analysis.hs view
@@ -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)
− Immutaball/Share/Level/Render.hs 
@@ -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)
Immutaball/Share/Level/Utils.hs view
@@ -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
Immutaball/Share/Math/Core.hs view
@@ -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
Immutaball/Share/Math/X3D.hs view
@@ -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.)
Immutaball/Share/Utils.hs view
@@ -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
Main.hs view
@@ -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:
+ NOTES-building-dependencies.md view
@@ -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+```
Putt.hs view
@@ -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:
README.md view
@@ -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: <https://byronjohnson.net/immutaball/immutaball-v0.1.0.1-demo.html>--## 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: <https://byronjohnson.net/immutaball/immutaball-v0.1.0.1-demo.html>.+(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 ```
Test.hs view
@@ -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:
+ Test/Data/LabeledBinTree/Orphans.hs view
@@ -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)]+			]+		)
+ Test/Data/LabeledBinTree/Test.hs view
@@ -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+			]+	]
Test/Immutaball/Share/Math/X3D/Test.hs view
@@ -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 			] 	]
Test/Immutaball/Test.hs view
@@ -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
+ dependency-substitutions/wires-fallback-meta/Control/Wire/Meta.hs view
@@ -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
+ dependency-substitutions/wires-nofallback-meta/Control/Wire/Meta.hs view
@@ -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
+ dependency-substitutions/wires/Control/Wire.hs view
@@ -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
+ dependency-substitutions/wires/Control/Wire/Controller.hs view
@@ -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
+ dependency-substitutions/wires/Control/Wire/Internal.hs view
@@ -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))
immutaball-core.cabal view
@@ -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