packages feed

immutaball-core (empty) → 0.1.0.4.1

raw patch · 84 files changed

+21461/−0 lines, 84 filesdep +HUnitdep +JuicyPixelsdep +OpenGLbinary-added

Dependencies added: HUnit, JuicyPixels, OpenGL, QuickCheck, array, async, base, bytestring, containers, curl, directory, filepath, gl, i18n, immutaball-core, lens, libvorbis, mtl, parallel, parsec, pipes, prettyprinter, sdl2, sdl2-ttf, stm, tasty, tasty-hunit, tasty-quickcheck, text, time, transformers, unbounded-delays, wires

Files

+ Control/Monad/Trans/MaybeM.hs view
@@ -0,0 +1,125 @@+{-# 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 #-}++-- State.hs.++{-# LANGUAGE Haskell2010 #-}+{-# LANGUAGE TemplateHaskell, InstanceSigs, ExplicitForAll, RankNTypes #-}++module Control.Monad.Trans.MaybeM+	(+		MaybeMT(..), maybeMT,+		runMaybeMT,+		runMaybeInMT,+		MaybeM,+		NaturalTransformation,+		liftNaturalTransformation,+		liftNT,+		runMaybeM+	) where++import Prelude ()+import Immutaball.Prelude++import Control.Applicative+import Control.Arrow+import Data.Functor.Identity++import Control.Lens+import Control.Monad+import Control.Monad.Fix+import Control.Monad.Trans.Class+import Control.Monad.Zip++newtype MaybeMT m a = MaybeMT { _maybeMT :: Either (m a) a }+	deriving (Eq, Ord, Show, Read)+makeLenses ''MaybeMT+instance MonadTrans MaybeMT where+	lift :: (Monad m) => m a -> MaybeMT m a+	lift = MaybeMT . Left+runMaybeMT :: MaybeMT m a -> Either (m a) a+runMaybeMT = _maybeMT++runMaybeInMT :: (Applicative m) => MaybeMT m a -> m a+runMaybeInMT = (id ||| pure) . runMaybeMT++type MaybeM = MaybeMT Identity++instance (Functor m) => Functor (MaybeMT m) where+	fmap :: (a -> b) -> (MaybeMT m a -> MaybeMT m b)+	fmap f = MaybeMT . either (Left . fmap f) (Right . f) . runMaybeMT++instance (Applicative m) => Applicative (MaybeMT m) where+	pure :: (Applicative m) => a -> MaybeMT m a+	pure = MaybeMT . Right+	(<*>) :: (Applicative m) => MaybeMT m (a -> b) -> MaybeMT m a -> MaybeMT m b+	(MaybeMT (Right f))  <*> (MaybeMT (Right a))  = MaybeMT (Right (f a))+	(MaybeMT (Left  mf)) <*> (MaybeMT (Left  ma)) = MaybeMT (Left (mf <*> ma))+	(MaybeMT (Right f))  <*> (MaybeMT (Left  ma)) = MaybeMT (Left (pure f <*> ma))+	(MaybeMT (Left  mf)) <*> (MaybeMT (Right a))  = MaybeMT (Left (mf <*> pure a))++instance (Monad m) => Monad (MaybeMT m) where+	return :: (Monad m) => a -> MaybeMT m a+	return = pure+	(>>=) :: (Monad m) => MaybeMT m a -> (a -> MaybeMT m b) -> MaybeMT m b+	(MaybeMT (Right a)) >>= f = f a+	(MaybeMT (Left ma)) >>= f = MaybeMT . Left $ ma >>= \a -> either id return $ runMaybeMT (f a)++instance (Monad m, MonadFix m) => MonadFix (MaybeMT m) where+	mfix :: (Monad m) => (a -> MaybeMT m a) -> MaybeMT m a+	mfix f = MaybeMT . Left . mfix $ \a -> either id return $ runMaybeMT (f a)++instance (Alternative m) => Alternative (MaybeMT m) where+	empty :: (Alternative m) => MaybeMT m a+	empty = MaybeMT . Left $ empty+	(<|>) :: (Alternative m) => MaybeMT m a -> MaybeMT m a -> MaybeMT m a+	--x@( MaybeMT (Right _a)) <|> _ = x+	_x@(MaybeMT (Right a))  <|> y = MaybeMT . Left $ pure a <|> (either id pure . runMaybeMT $ y)+	_x@(MaybeMT (Left  ma)) <|> y = MaybeMT . Left $ ma     <|> (either id pure . runMaybeMT $ y)++instance (MonadPlus m) => MonadPlus (MaybeMT m) where+	mzero :: (MonadPlus m) => MaybeMT m a+	mzero = MaybeMT . Left $ mzero+	mplus :: (MonadPlus m) => MaybeMT m a -> MaybeMT m a -> MaybeMT m a+	--x@( MaybeMT (Right _a)) `mplus` _ = x+	_x@(MaybeMT (Right a))  `mplus` y = MaybeMT . Left $ pure a `mplus` (either id pure . runMaybeMT $ y)+	_x@(MaybeMT (Left  ma)) `mplus` y = MaybeMT . Left $ ma     `mplus` (either id pure . runMaybeMT $ y)++instance (Foldable m) => Foldable (MaybeMT m) where+	foldr :: (Foldable m) => (a -> b -> b) -> b -> MaybeMT m a -> b+	foldr reduce reduction0 (MaybeMT (Right a))  = reduce a reduction0+	foldr reduce reduction0 (MaybeMT (Left  ma)) = foldr reduce reduction0 ma++instance (Traversable m) => Traversable (MaybeMT m) where+	traverse :: (Traversable m, Applicative f) => (a -> f b) -> MaybeMT m a -> f (MaybeMT m b)+	traverse traversal_ (MaybeMT (Right a))  = pure (MaybeMT . Right) <*> traversal_ a+	traverse traversal_ (MaybeMT (Left  ma)) = pure (MaybeMT . Left)  <*> traverse traversal_ ma++instance (MonadZip m) => MonadZip (MaybeMT m) where+	mzip :: (MonadZip m) => MaybeMT m a -> MaybeMT m b -> MaybeMT m (a, b)+	mzip (MaybeMT (Right a))  (MaybeMT (Right b))  = MaybeMT (Right (a, b))+	mzip (MaybeMT (Left  ma)) (MaybeMT (Left  mb)) = MaybeMT (Left (mzip ma mb))+	mzip (MaybeMT (Right a))  (MaybeMT (Left  mb)) = MaybeMT (Left (mzip (pure a) mb))+	mzip (MaybeMT (Left  ma)) (MaybeMT (Right b))  = MaybeMT (Left (mzip ma (pure b)))++type NaturalTransformation m n = forall a. m a -> n a++-- | We _could_ require a natural transformation if we wanted, but since the+-- argument is to the _left_ of an arrow, not to the right, then rather than+-- outputting as specifically as we can, we want to input as generally as we+-- can.+--liftNaturalTransformation :: NaturalTransformation m n -> (MaybeMT m a -> MaybeMT n a)+liftNaturalTransformation :: (m a -> n a) -> (MaybeMT m a -> MaybeMT n a)+liftNaturalTransformation _nt (MaybeMT (Right a))  = MaybeMT (Right a)+liftNaturalTransformation  nt (MaybeMT (Left  ma)) = MaybeMT (Left (nt ma))++-- | Alias for 'liftNaturalTransformation'.+--liftNT :: NaturalTransformation m n -> (MaybeMT m a -> MaybeMT n a)+liftNT :: (m a -> n a) -> (MaybeMT m a -> MaybeMT n a)+liftNT = liftNaturalTransformation++-- | Simplify a MaybeMT if the possible monad is 'Identity'.+runMaybeM :: MaybeM a -> a+runMaybeM (MaybeMT (Right a))           = a+runMaybeM (MaybeMT (Left (Identity a))) = a
+ Immutaball/Ball/CLI.hs view
@@ -0,0 +1,248 @@+{-# 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 #-}++module Immutaball.Ball.CLI+	(+		main,+		immutaballMain,+		immutaballCLIMain',+		immutaballCLIMain,+		mainImmutaballIO',+		mainImmutaballIO,+		immutaballOptions,+		immutaballWithArgs,+		immutaballHelp,+		immutaballVersion,+		immutaballWithCLIConfig,+		cliIBDirs,+		getDefaultIBDirs,+		immutaballWithCLIConfig',+		immutaballWithNeverballrc,+		immutaballWithContext,+		initialImmutaball,+		defaultInitialImmutaball+	) where++-- Prelude imports+import Prelude ()+import Immutaball.Prelude++-- base imports+import Control.Arrow+import Data.List+import System.Console.GetOpt+import Text.Printf++-- external imports+import Control.Lens+import qualified Data.Text as T+import System.FilePath++-- internal imports+import Immutaball.Ball.CLI.Config+import Immutaball.Ball.State.Title+import Immutaball.Share.Config+import Immutaball.Share.Config.Parser+import Immutaball.Share.Config.Printer+import Immutaball.Share.Context+import Immutaball.Share.Context.Config+import Immutaball.Share.Controller+import Immutaball.Share.ImmutaballIO+import Immutaball.Share.ImmutaballIO.BasicIO+import Immutaball.Share.State+import Immutaball.Share.Utils++main :: IO ()+main = immutaballMain++immutaballMain :: IO ()+immutaballMain = immutaballCLIMain'++immutaballCLIMain' :: IO ()+immutaballCLIMain' = immutaballCLIMain defaultStaticConfig++immutaballCLIMain :: StaticConfig -> IO ()+immutaballCLIMain x'cfg = do+	runImmutaballIO (mainImmutaballIO x'cfg)++mainImmutaballIO' :: ImmutaballIO+mainImmutaballIO' = mainImmutaballIO defaultStaticConfig++mainImmutaballIO :: StaticConfig -> ImmutaballIO+mainImmutaballIO x'cfg =+	mkBIO . GetArgsSync $ immutaballWithArgs x'cfg++immutaballOptions :: [OptDescr CLIConfigBuilder]+immutaballOptions =+	[+		Option ['H', '?'] ["help"]       (NoArg . b $ cliCfgHelp    .~ True)+			"Show help and exit",+		Option []         ["no-help"]    (NoArg . b $ cliCfgHelp    .~ False)+			"",+		Option ['V']      ["version"]    (NoArg . b $ cliCfgVersion .~ True)+			"Show version and exit",+		Option []         ["no-version"] (NoArg . b $ cliCfgVersion .~ False)+			"",++		Option ['d'] ["static-data-dir", "data"] (ReqArg (\path -> b $ cliCfgStaticDataDir .~ Just path) "")+			"Set static data directory path",+		Option []    ["user-data-dir"]           (ReqArg (\path -> b $ cliCfgUserDataDir   .~ Just path) "")+			"Set user data directory path",+		Option []    ["user-config-dir"]         (ReqArg (\path -> b $ cliCfgUserConfigDir .~ Just path) "")+			"Set user config directory path",++		Option [] ["no-static-data-dir"] (NoArg . b $ cliCfgStaticDataDir .~ Nothing)+			"",+		Option [] ["no-user-data-dir"]   (NoArg . b $ cliCfgUserDataDir   .~ Nothing)+			"",+		Option [] ["no-user-config-dir"] (NoArg . b $ cliCfgUserConfigDir .~ Nothing)+			"",++		Option [] ["headless"] (NoArg . b $ cliCfgHeadless .~ True)+			"",+		Option [] ["no-headless"] (NoArg . b $ cliCfgHeadless .~ False)+			""+	]+	where b = CLIConfigBuilder++immutaballWithArgs :: StaticConfig -> [String] -> ImmutaballIO+immutaballWithArgs x'cfg args =+	result+	where+		opts :: [CLIConfigBuilder]+		nonopts, errs :: [String]+		(opts, nonopts, errs) = getOpt Permute immutaballOptions args+		cliCfg = buildCLIConfig (mconcat opts)+		showErrs :: [String] -> ImmutaballIO+		showErrs errs_ = foldr (<>>) mempty $ showErr <$> errs_+		showErr :: String -> ImmutaballIO+		showErr errMsg = mkBIO . PutStrLn (printf "Error: CLI getOpt error: %s" errMsg) $ mkBIO ExitFailureBasicIOF+		result :: ImmutaballIO+		result+			| (not . null) errs    = showErrs errs <>> mkBIO ExitFailureBasicIOF+			| (not . null) nonopts = showErrs $ map (\nonopt -> printf "nonoptions currently not supported; received nonoption ‘%s’" nonopt) nonopts+			| otherwise            = immutaballWithCLIConfig x'cfg cliCfg++immutaballHelp :: String+immutaballHelp = intercalate "\n" $+	[+		"Usage: immutaball [options…]",+		"",+		"Options:",+		"\t--help: Show usage and exit.",+		"\t--version: Show version and exit.",+		"\t-d PATH, --data PATH, --static-data-dir PATH:",+		"\t\tSet static data directory path.",+		"\t--user-data-dir PATH:",+		"\t\tSet user data directory path.",+		"\t--user-config-dir PATH:",+		"\t\tSet user config directory path.",+		"\t--headless:",+		"\t\tDisable video and audio.  Useful for automated testing."+	]++immutaballVersion :: String+immutaballVersion = "0.1.0.4.1-hackage"++-- | Run immutaball.+immutaballWithCLIConfig :: StaticConfig -> CLIConfig -> ImmutaballIO+immutaballWithCLIConfig x'cfg cliCfg =+	result+	where+		showHelp :: ImmutaballIO+		showHelp = mkBIO . PutStrLn immutaballHelp $ mkBIO ExitSuccessBasicIOF+		showVersion :: ImmutaballIO+		showVersion = mkBIO . PutStrLn immutaballVersion $ mkBIO ExitSuccessBasicIOF+		result :: ImmutaballIO+		result+			| cliCfg^.cliCfgHelp    = showHelp+			| cliCfg^.cliCfgVersion = showVersion+			| otherwise             = immutaballWithCLIConfig' x'cfg cliCfg++cliIBDirs :: CLIConfig -> IBDirs -> IBDirs+cliIBDirs cliCfg defaultIBDirs = IBDirs {+	_ibStaticDataDir = maybe (defaultIBDirs^.ibStaticDataDir) id (cliCfg^.cliCfgStaticDataDir),+	_ibUserDataDir   = maybe (defaultIBDirs^.ibUserDataDir)   id (cliCfg^.cliCfgUserDataDir),+	_ibUserConfigDir = maybe (defaultIBDirs^.ibUserConfigDir) id (cliCfg^.cliCfgUserConfigDir)+}++getDefaultIBDirs :: StaticConfig -> (IBDirs -> ImmutaballIO) -> ImmutaballIO+getDefaultIBDirs x'cfg withIBDirs =+	either (\d f -> mkBIO . DirectoryIO . fmap f $ d) (&) (x'cfg^.defaultStaticDataDir) $ \defaultStaticDataDir_ ->+	either (\d f -> mkBIO . DirectoryIO . fmap f $ d) (&) (x'cfg^.defaultUserDataDir)   $ \defaultUserDataDir_ ->+	either (\d f -> mkBIO . DirectoryIO . fmap f $ d) (&) (x'cfg^.defaultUserConfigDir) $ \defaultUserConfigDir_ ->+	withIBDirs $ IBDirs {+		_ibStaticDataDir = defaultStaticDataDir_,+		_ibUserDataDir   = defaultUserDataDir_,+		_ibUserConfigDir = defaultUserConfigDir_+	}++-- | Run immutaball after basic setup like checking for ‘--help’.+immutaballWithCLIConfig' :: StaticConfig -> CLIConfig -> ImmutaballIO+immutaballWithCLIConfig' x'cfg cliCfg =+	result+	where+		result :: ImmutaballIO+		result = getDefaultIBDirs x'cfg withDefaultIBDirs+		withDefaultIBDirs :: IBDirs -> ImmutaballIO+		withDefaultIBDirs defaultIBDirs = result_+			where+				result_ :: ImmutaballIO+				result_ = createUserDirsIfMissing <>> (mkBIO . DoesPathExistSync neverballrcPath $ withNeverballrcExists)+				createUserDirsIfMissing :: ImmutaballIO+				createUserDirsIfMissing = mconcat . map (mkBIO . flip CreateDirectoryIfMissing mempty) $ [ibDirs_^.ibUserDataDir, ibDirs_^.ibUserConfigDir]+				ibDirs_ :: IBDirs+				ibDirs_ = cliIBDirs cliCfg defaultIBDirs+				neverballrcPath :: FilePath+				neverballrcPath = (ibDirs_^.ibUserConfigDir) </> (x'cfg^.configFilename)+				writeDefaultNeverballrc :: ImmutaballIO+				writeDefaultNeverballrc = mkBIO $ WriteText neverballrcPath (T.pack . showNeverballrc $ defaultNeverballrc) mempty+				defaultNeverballrc :: Neverballrc+				defaultNeverballrc = defaultConfig+				withNeverballrcExists :: Bool -> ImmutaballIO+				withNeverballrcExists False = writeDefaultNeverballrc <>> withNeverballrcExists True+				withNeverballrcExists True = result_2+					where+						result_2 :: ImmutaballIO+						result_2 = mkBIO . ReadTextSync neverballrcPath . (mkThrowIO |||) $ \neverballrcContents -> withParse $ parseNeverballrc neverballrcPath (T.unpack neverballrcContents)+						withParse :: Either String Neverballrc -> ImmutaballIO+						withParse (Left  parseError)   = mkBIO . PutStrLn (printf "Error: failed to parse neverballrc: %s" parseError) $ mkBIO ExitFailureBasicIOF+						withParse (Right neverballrc_) = immutaballWithNeverballrc x'cfg cliCfg ibDirs_ neverballrc_++--- | Run immutaball after getting neverballrc and dirs.+immutaballWithNeverballrc :: StaticConfig -> CLIConfig -> IBDirs -> Neverballrc -> ImmutaballIO+immutaballWithNeverballrc x'cfg cliCfg ibDirs_ nrcCfg =+	result+	where+		result :: ImmutaballIO+		result = withSDL cxtCfg immutaballWithContext+		cxtCfg :: ContextConfig+		cxtCfg = ContextConfig {+			_cxtCfgStaticConfig = x'cfg,+			_cxtCfgDirs         = ibDirs_,+			_cxtCfgNeverballrc  = nrcCfg,+			_cxtCfgInitialWire  = joinMaybeResult $ (x'cfg^.x'cfgInitialWireWithCxt),+			_cxtCfgHeadless     = (cliCfg^.cliCfgHeadless),++			_cxtCfgUseExistingSDLManager = (x'cfg^.x'cfgUseExistingSDLManager),+			_cxtCfgUseExistingGLManager  = (x'cfg^.x'cfgUseExistingGLManager)+		}++--- | Run immutaball after setting up an initial immutaball context.+immutaballWithContext :: IBContext -> ImmutaballIO+immutaballWithContext cxt0 =+	result+	where+		result :: ImmutaballIO+		result = controlImmutaball cxt0 (initialImmutaball cxt0)++initialImmutaball :: IBContext -> Immutaball+initialImmutaball cxt0 = maybe (defaultInitialImmutaball cxt0) id $ (cxt0^.ibInitialWire) cxt0++defaultInitialImmutaball :: IBContext -> Immutaball+defaultInitialImmutaball cxt0 = mkTitleState (Left cxt0)
+ Immutaball/Ball/CLI/Config.hs view
@@ -0,0 +1,55 @@+{-# 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 #-}++-- State.hs.++{-# LANGUAGE Haskell2010 #-}+{-# LANGUAGE TemplateHaskell, InstanceSigs #-}++module Immutaball.Ball.CLI.Config+	(+		CLIConfig(..), cliCfgHelp, cliCfgVersion, cliCfgStaticDataDir,+			cliCfgUserDataDir, cliCfgUserConfigDir, cliCfgHeadless,+		defaultCLIConfig,+		CLIConfigBuilder(..), modifyCLIConfig,+		buildCLIConfig+	) where++import Prelude ()+import Immutaball.Prelude++import Control.Lens++data CLIConfig = CLIConfig {+	_cliCfgHelp          :: Bool,+	_cliCfgVersion       :: Bool,+	_cliCfgStaticDataDir :: Maybe FilePath,+	_cliCfgUserDataDir   :: Maybe FilePath,+	_cliCfgUserConfigDir :: Maybe FilePath,+	_cliCfgHeadless      :: Bool+}+	deriving (Eq, Ord)+makeLenses ''CLIConfig++defaultCLIConfig :: CLIConfig+defaultCLIConfig = CLIConfig {+	_cliCfgHelp          = False,+	_cliCfgVersion       = False,+	_cliCfgStaticDataDir = Nothing,+	_cliCfgUserDataDir   = Nothing,+	_cliCfgUserConfigDir = Nothing,+	_cliCfgHeadless      = False+}++newtype CLIConfigBuilder = CLIConfigBuilder {_modifyCLIConfig :: CLIConfig -> CLIConfig}+makeLenses ''CLIConfigBuilder++instance Semigroup CLIConfigBuilder where+	(<>) :: CLIConfigBuilder -> CLIConfigBuilder -> CLIConfigBuilder+	a <> b = CLIConfigBuilder $ (b^.modifyCLIConfig) . (a^.modifyCLIConfig)+instance Monoid CLIConfigBuilder where+	mempty = CLIConfigBuilder $ id++buildCLIConfig :: CLIConfigBuilder -> CLIConfig+buildCLIConfig builder = (builder^.modifyCLIConfig) defaultCLIConfig
+ Immutaball/Ball/Game.hs view
@@ -0,0 +1,461 @@+{-# 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 #-}++-- Game.hs.++{-# LANGUAGE Haskell2010 #-}+{-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-}++module Immutaball.Ball.Game+	(+		ChallengeModeState(..), cmsTotalCoins, cmsTotalTimeCs, cmsTotalDeaths,+		initialChallengeModeState,++		GameMode(..), AsGameMode(..),+		isPlaying, isFallOut, isTimesUp, isWin, isPaused, isIntermission,+			isGameEnded, isGameFailed, isGameRunning,+		GameState(..), gsGameMode, gsTimeElapsed, gsPaused, gsPreview,+			gsBallPos, gsBallVel, gsBallRot, gsBallRadius, gsSolRaw, gsSol,+			gsSolAttributes, gsSolAnalysis, gsSwa, gsCameraAngle, gsCameraMode,+			gsCoinState, gsSwitchState, gsPathState, gsTeleporterState,+			gsGoalState, gsGravityState, gsDebugState, gsInputState,+			{- gsAnalysis, -}+		GameStateAnalysis(..), gsaView, gsaNetRightForwardJump,+			gsaNetMouseRight, gsaUpVec,+		mkGameStateAnalysis,+		initialGameState,+		CoinState(..), csCoinsCollected, csTotalCollected, csTotalUncollected,+			csCoinCollectedAt, csCoinsUncollected,+		SwitchState(..), xsSwitchesEnabled, xsSwitchesTimers, xsBallInAnySwitch, xsBallInSwitch,+		PathState(..), psPathsTimeElapsed, psPathsGoing,+		TeleporterState(..), jsBallInAnyTeleporter, jsBallBeingTeleported,+		GoalState(..), zsCoinUnlocked, zsStartUnlocked, zsUnlocked,+		GravityState(..), gravsTiltRightRadians, gravsTiltForwardRadians,+		GameDebugState(..), gdsCameraDebugOn, gdsCameraPosOffset,+			gdsCameraAimRightRadians, gdsCameraAimUpRadians,+		GameInputState(..), ginsRightOn, ginsLeftOn, ginsForwardOn,+			ginsBackwardOn, ginsVertUpOn, ginsVertDownOn, ginsMouseLeftOn,+			ginsMouseRightOn+	) where++import Prelude ()+import Immutaball.Prelude++import Data.Function hiding (id, (.))+import Data.Int+import Data.Maybe++import Control.Lens+import Control.Parallel+import Data.Array.IArray+import qualified Data.Map as M+import qualified Data.Set as S++import Immutaball.Ball.LevelSets+import Immutaball.Share.Config+import Immutaball.Share.Context+import Immutaball.Share.Level.Analysis+import Immutaball.Share.Level.Attributes+import Immutaball.Share.Level.Base+import Immutaball.Share.Level.Utils+import Immutaball.Share.Math+import Immutaball.Share.State.Context+import Immutaball.Share.Utils++data ChallengeModeState = ChallengeModeState {+	_cmsTotalCoins  :: Integer,+	_cmsTotalTimeCs :: Integer,  -- ^ centiseconds+	_cmsTotalDeaths :: Integer+}+makeLenses ''ChallengeModeState++initialChallengeModeState :: ChallengeModeState+initialChallengeModeState = ChallengeModeState {+	_cmsTotalCoins  = 0,+	_cmsTotalTimeCs = 0,+	_cmsTotalDeaths = 0+}++data GameMode =+	  Playing+	| FallOut+	| TimesUp+	| Win+	| Paused+	| Intermission+	deriving (Eq, Ord, Enum, Bounded, Show)+makeClassyPrisms ''GameMode++isPlaying :: GameMode -> Bool+isPlaying Playing = True+isPlaying _       = False++isFallOut :: GameMode -> Bool+isFallOut FallOut = True+isFallOut _       = False++isTimesUp :: GameMode -> Bool+isTimesUp TimesUp = True+isTimesUp _       = False++isWin :: GameMode -> Bool+isWin Win = True+isWin _   = False++isPaused :: GameMode -> Bool+isPaused Paused = True+isPaused _      = False++isIntermission :: GameMode -> Bool+isIntermission Intermission = True+isIntermission _            = False++isGameEnded :: GameMode -> Bool+isGameEnded FallOut = True+isGameEnded TimesUp = True+isGameEnded Win     = True+isGameEnded _       = False++isGameFailed :: GameMode -> Bool+isGameFailed FallOut = True+isGameFailed TimesUp = True+isGameFailed _       = False++isGameRunning :: GameMode -> Bool+isGameRunning Playing = True+isGameRunning _       = False++data GameState = GameState {+	-- | Are we playing, won, fell out, etc.?+	_gsGameMode :: GameMode,++	-- | Game time elapsed.+	_gsTimeElapsed :: Double,+	-- | Is paused.+	_gsPaused :: Bool,+	-- | Is in intermission.  Time elapsed in intermission.+	_gsPreview :: Maybe Double,+	-- | The position of the ball.+	_gsBallPos :: Vec3 Double,+	-- | The velocity of the ball.+	_gsBallVel :: Vec3 Double,+	-- | The rotation of the ball about each axis.  Radians.+	_gsBallRot :: Vec3 Double,+	-- | The radius of the ball.+	_gsBallRadius :: Double,++	-- | Directly parsed sol, level file.+	_gsSolRaw :: LevelIB,+	-- | Postprocessed sol: apply restoring transformation.+	_gsSol :: LevelIB,+	-- | Read metadata from the sol.+	_gsSolAttributes :: SolAttributes,+	-- | Optionally make our own analysis from the SOL.+	_gsSolAnalysis :: SolAnalysis,+	-- | Convenience pairing of the sol with the analysis.+	_gsSwa :: SolWithAnalysis,++	-- | The angle of the camera behind the ball - how much to ‘look right’+	-- (yaw).+	--+	-- Rendering is oriented by 'tilt3y' so that the positive y axis direction+	-- represents what the camera is looking at.  Equivalently, this angle+	-- specifies what clock-wise angle to rotate the camera by around the ball.+	_gsCameraAngle :: Double,+	_gsCameraMode :: Integer,++	_gsCoinState :: CoinState,+	_gsSwitchState :: SwitchState,+	_gsPathState :: PathState,+	_gsTeleporterState :: TeleporterState,+	_gsGoalState :: GoalState,++	_gsGravityState :: GravityState,++	_gsDebugState :: GameDebugState,++	_gsInputState :: GameInputState++	{-+	-- | Composite data e.g. for the play state to know where the camera is,+	-- built from game state data.+	_gsAnalysis :: GameStateAnalysis+	-}+}+	deriving (Eq, Ord, Show)+--makeLenses ''GameState++data GameStateAnalysis = GameStateAnalysis {+	-- | Where the camera is.+	_gsaView :: MView,+	-- | Net movement from input state: -1 for opposite, 0 for neutral, 1 for On.+	_gsaNetRightForwardJump :: (Integer, Integer, Integer),+	-- | Net mouse left/right button down state: -1 if left only is down, 0 if neutral, 1 if right clicking only.+	_gsaNetMouseRight :: Integer,+	-- | Given the current world tilt, find the upvec (new z axis).  This does+	-- not yet include camera rotation; this is relative to the initial camera+	-- pos (looking straight down the positive y axis).  TODO: make it include+	-- the camera rotation, which seems to me to make more sense.+	_gsaUpVec :: Vec3 Double+}+	deriving (Eq, Ord, Show)++--mkGameStateAnalysis++data CoinState = CoinState {+	_csCoinsCollected :: M.Map Int32 Bool,++	-- Utility data.+	_csTotalCollected :: Integer,+	_csTotalUncollected :: Integer,+	_csTotalCoinValue :: Integer,+	_csCoinCollectedAt :: M.Map Int32 Double,+	_csCoinsUncollected :: S.Set Int32+}+	deriving (Eq, Ord, Show)+--makeLenses ''CoinState++data SwitchState = SwitchState {+	_xsSwitchesEnabled :: M.Map Int32 Bool,+	-- | Time left.+	_xsSwitchesTimers :: M.Map Int32 Double,++	_xsBallInAnySwitch :: Bool,+	_xsBallInSwitch :: M.Map Int32 Bool+}+	deriving (Eq, Ord, Show)+--makeLenses ''SwitchState++data PathState = PathState {+	_psPathsTimeElapsed :: M.Map Int32 Double,+	_psPathsGoing :: M.Map Int32 Bool+}+	deriving (Eq, Ord, Show)+--makeLenses ''PathState++data TeleporterState = TeleporterState {+	_jsBallInAnyTeleporter :: Bool,+	-- | Which teleporter, and teleportation time elapsed (in seconds, as usual).+	_jsBallBeingTeleported :: Maybe (Int32, Double)+}+	deriving (Eq, Ord, Show)+--makeLenses ''TeleporterState++data GoalState = GoalState {+	_zsCoinUnlocked :: Bool,+	_zsStartUnlocked :: Bool,+	-- | coin || start:+	_zsUnlocked :: Bool+}+	deriving (Eq, Ord, Show)+--makeLenses ''GoalState++data GravityState = GravityState {+	_gravsTiltRightRadians   :: Double,+	_gravsTiltForwardRadians :: Double+}+	deriving (Eq, Ord, Show)+--makeLenses ''GravityState++data GameDebugState = GameDebugState {+	_gdsCameraDebugOn  :: Bool,+	_gdsCameraPosOffset :: Vec3 Double,+	_gdsCameraAimRightRadians :: Double,+	_gdsCameraAimUpRadians :: Double+}+	deriving (Eq, Ord, Show)+--makeLenses ''GameDebugState++-- | For input with greater preservation.+data GameInputState = GameInputState {+	_ginsRightOn    :: Bool,  -- Right arrow pressed?+	_ginsLeftOn     :: Bool,  -- Left arrow pressed?+	_ginsForwardOn  :: Bool,  -- Up arrow?+	_ginsBackwardOn :: Bool,  -- Down arrow?+	_ginsVertUpOn   :: Bool,  -- Spacebar?  (Not used in regular gameplay.)+	_ginsVertDownOn :: Bool,  -- ‘c’ for qwerty crouch to move down?  (Not used in regular gameplay.)++	_ginsMouseLeftOn  :: Bool,  -- Mouse left button is being pressed on?+	_ginsMouseRightOn :: Bool   -- Mouse right button is being pressed on?+}+	deriving (Eq, Ord, Show)+--makeLenses ''GameDebugState++makeLenses ''GameState+makeLenses ''GameStateAnalysis+makeLenses ''CoinState+makeLenses ''SwitchState+makeLenses ''PathState+makeLenses ''TeleporterState+makeLenses ''GoalState+makeLenses ''GravityState+makeLenses ''GameDebugState+makeLenses ''GameInputState++initialGameState :: IBContext' a -> Neverballrc -> Bool -> Maybe LevelSet -> String -> LevelIB -> GameState+initialGameState cxt neverballrc hasLevelBeenCompleted mlevelSet solPath sol = fix $ \gs ->+	let solAnalysis = mkSolAnalysis cxt (gs^.gsSol) in+	par (M.size $ solAnalysis^.saPhysicsAnalysis.spaLumpPlanes) .+	par solAnalysis $+	GameState {+		_gsGameMode    = Intermission,++		_gsTimeElapsed = 0.0,+		_gsPaused      = False,+		_gsPreview     = Just 0.0,+		_gsBallPos     = ((^.ballP) <$> ((gs^.gsSol.solUv) !? 0)) & fromMaybe (Vec3 0.0 0.0 0.0),+		_gsBallVel     = Vec3 0.0 0.0 0.0,+		_gsBallRot     = Vec3 0.0 0.0 0.0,+		_gsBallRadius  = ((^.ballR) <$> ((gs^.gsSol.solUv) !? 0)) & fromMaybe (1.0),++		_gsSolRaw        = sol,+		_gsSol           = postprocessSol restoreSolTransformation (gs^.gsSolRaw),+		_gsSolAttributes = mkSolAttributes (gs^.gsSol),+		_gsSolAnalysis   = solAnalysis,+		_gsSwa           = SolWithAnalysis {+			_swaSol  = (gs^.gsSol),+			_swaSa   = solAnalysis,+			_swaMeta = SolMeta {+				_smPath     = solPath,+				_smLevelSet = mlevelSet+			}+		},++		_gsCameraAngle = 0.0,+		_gsCameraMode  = fromIntegral $ (neverballrc^.camera),++		_gsCoinState = CoinState {+			_csCoinsCollected = M.fromList [(k, v) | v <- return False, k <- range . bounds $ (gs^.gsSol.solHv)],++			_csTotalCollected   = 0,+			_csTotalUncollected = (gs^.gsCoinState.csTotalCoinValue),+			_csTotalCoinValue   = sum [v | coin <- elems (gs^.gsSol.solHv), v <- return . fromIntegral $ (coin^.itemN)],+			_csCoinCollectedAt  = M.empty,+			_csCoinsUncollected = S.fromList . range . bounds $ (gs^.gsSol.solHv)+		},+		_gsSwitchState = SwitchState {+			_xsSwitchesEnabled = M.fromList [(k, v) | k <- range . bounds $ (gs^.gsSol.solXv), x <- return $ (gs^.gsSol.solXv) ! k, v <- return $ (x^.swchF) /= 0],+			_xsSwitchesTimers  = M.fromList [(k, v) | k <- range . bounds $ (gs^.gsSol.solXv), x <- return $ (gs^.gsSol.solXv) ! k, v <- return $ (x^.swchT)],++			_xsBallInAnySwitch = False,+			_xsBallInSwitch    = M.fromList [(k, v) | v <- return False, k <- range . bounds $ (gs^.gsSol.solXv)]+		},+		_gsPathState = PathState {+			_psPathsTimeElapsed = M.fromList [(k, v) | v <- return 0, k <- range . bounds $ (gs^.gsSol.solPv)],+			_psPathsGoing       = M.fromList [(k, v) | k <- range . bounds $ (gs^.gsSol.solPv), p <- return $ (gs^.gsSol.solPv) ! k, v <- return $ (p^.pathF) /= 0]+		},+		_gsTeleporterState = TeleporterState {+			_jsBallInAnyTeleporter = False,+			_jsBallBeingTeleported = Nothing+		},+		_gsGoalState = GoalState {+			_zsCoinUnlocked  = 0 >= (gs^.gsSolAttributes.saGoal),+			_zsStartUnlocked = (not (neverballrc^.lockGoals)) && hasLevelBeenCompleted,+			_zsUnlocked      = (gs^.gsGoalState.zsCoinUnlocked) || (gs^.gsGoalState.zsStartUnlocked)+		},++		_gsGravityState = GravityState {+			_gravsTiltRightRadians   = 0.0,+			_gravsTiltForwardRadians = 0.0+		},++		_gsDebugState = GameDebugState {+			_gdsCameraDebugOn         = False,+			_gdsCameraPosOffset       = zv3,+			_gdsCameraAimRightRadians = 0.0,+			_gdsCameraAimUpRadians    = 0.0+		},++		_gsInputState = GameInputState {+			_ginsRightOn    = False,+			_ginsLeftOn     = False,+			_ginsForwardOn  = False,+			_ginsBackwardOn = False,+			_ginsVertUpOn   = False,+			_ginsVertDownOn = False,++			_ginsMouseLeftOn  = False,+			_ginsMouseRightOn = False+		}++		{-+		_gsAnalysis = mkGameStateAnalysis gs,+		-}+	}++mkGameStateAnalysis :: IBStateContext -> GameState -> GameStateAnalysis+mkGameStateAnalysis cxt gs = fix $ \_gsa -> GameStateAnalysis {+	_gsaView                = theView,+	_gsaNetRightForwardJump = theNetRightForwardJump,+	_gsaNetMouseRight       = theNetMouseRight,+	_gsaUpVec               = theUpVec+}+	where+		theView :: MView+		theView =+			let (mviewDefault :: MView) = MView {+				_mviewPos    = Vec3 0.0 0.0 0.0,+				_mviewTarget = Vec3 0.0 1.0 0.0,+				_mviewFov    = 2 * (fromIntegral $ cxt^.ibNeverballrc.viewFov)+			} in+			let (maybeView :: Maybe View) = (gs^.gsSol.solWv) !? 0 in+			let gds = gs^.gsDebugState in+			let (mviewIntermission :: MView) = (\f -> maybe mviewDefault f maybeView) $ \view_ ->+				let targetQDiff = (view_^.viewQ) `minusv3` (view_^.viewP) in+				let rotatedTargetQDiff = aimVert3DSimple (Just $ 0.99*(tau/4)) (gds^.gdsCameraAimUpRadians) . aimHoriz3DSimple (gds^.gdsCameraAimRightRadians) $ targetQDiff in++				let+					debugViewTarget = (view_^.viewP) `pv3` rotatedTargetQDiff `pv3` ddebugViewPos+					ddebugViewTarget' = debugViewTarget `minusv3` (view_^.viewQ)++					(ddebugViewPos, ddebugViewTarget) = if' (not (gds^.gdsCameraDebugOn)) (zv3, zv3) $ (gds^.gdsCameraPosOffset, ddebugViewTarget') in+				MView {+					_mviewPos    = (view_^.viewP) `pv3` ddebugViewPos,+					_mviewTarget = (view_^.viewQ) `pv3` ddebugViewTarget,+					-- (The neverballrc fov appears to be half fov, not whole fov, so double the degrees, then convert to radians.)+					_mviewFov    = let deg = 2.0 * (fromIntegral $ cxt^.ibNeverballrc.viewFov) in deg * (tau/360.0)+				} in+			-- TODO: use .neverballrc viewDp, viewDc, and viewDz.  For now just+			-- use static config for camera orientation about ball.+			let (mviewCamera :: MView) =+				let (cameraOffset :: Vec3 Double) =+					aimVert3DSimple Nothing ((cxt^.ibContext.ibStaticConfig.x'cfgCameraRaisedCircles) * tau) .+					sv3 (cxt^.ibContext.ibStaticConfig.x'cfgCameraDistance) $+					Vec3 0.0 (-1.0) 0.0 in+				MView {+					_mviewPos = (gs^.gsBallPos) `pv3` cameraOffset,+					_mviewTarget = gs^.gsBallPos,+					-- Same fov as calculated in intermission; just copy it.+					_mviewFov = mviewIntermission^.mviewFov+				} in+			let (mview :: MView) = if' (isIntermission $ gs^.gsGameMode) mviewIntermission mviewCamera in+			mview++		theNetRightForwardJump :: (Integer, Integer, Integer)+		theNetRightForwardJump = (netRight, netForward, netVertUp)+			where+				netOf :: Bool -> Bool -> Integer+				netOf True  False = -1+				netOf False False =  0+				netOf False True  =  1+				netOf True  True  =  0++				netRight   = netOf (gs^.gsInputState.ginsLeftOn)     (gs^.gsInputState.ginsRightOn)+				netForward = netOf (gs^.gsInputState.ginsBackwardOn) (gs^.gsInputState.ginsForwardOn)+				netVertUp  = netOf (gs^.gsInputState.ginsVertDownOn) (gs^.gsInputState.ginsVertUpOn)++		theNetMouseRight = (netMouseRight)+			where+				netOf :: Bool -> Bool -> Integer+				netOf True  False = -1+				netOf False False =  0+				netOf False True  =  1+				netOf True  True  =  0++				netMouseRight = netOf (gs^.gsInputState.ginsMouseLeftOn)     (gs^.gsInputState.ginsMouseRightOn)++		theUpVec :: Vec3 Double+		theUpVec = fix $ \upVec -> Vec3 (sin $ gs^.gsGravityState.gravsTiltRightRadians) (sin $ gs^.gsGravityState.gravsTiltForwardRadians) (sqrt $ 1 - sq_ (upVec^.xy3.r2))+			where+				sq_ x = x*x
+ Immutaball/Ball/LevelSets.hs view
@@ -0,0 +1,123 @@+{-# 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 #-}++-- LevelSets.hs.++{-# LANGUAGE Haskell2010 #-}+{-# LANGUAGE TemplateHaskell #-}++module Immutaball.Ball.LevelSets+	(+		ChallengeModeScores(..), cmsBestTimes, cmsMostCoins,+		LevelSet(..), lsTitle, lsDesc, lsName, lsPict, lsChallengeModeScores, lsLevels,+		LevelSets(..), lsExplicitSets, lsLevelSets,+		getLevelSets,+		getLevelSet,++		-- * Utils+		challengeModeLine+	) where++import Prelude ()+import Immutaball.Prelude++import Control.Arrow++import Control.Lens+import qualified Data.Text as T+import qualified Data.Map as M+import System.FilePath+import Text.Parsec++import Immutaball.Share.Config.Parser+import Immutaball.Share.Context+import Immutaball.Share.Context.Config+import Immutaball.Share.ImmutaballIO+import Immutaball.Share.ImmutaballIO.BasicIO++data ChallengeModeScores = ChallengeModeScores {+	_cmsBestTimes :: (Integer, Integer, Integer),+	_cmsMostCoins :: (Integer, Integer, Integer)+}+	deriving (Eq, Ord, Show)+makeLenses ''ChallengeModeScores++data LevelSet = LevelSet {+	-- | "My Levels"+	_lsTitle :: String,+	-- | "A level set.\\Another paragraph.\Another line in the paragraph."+	_lsDesc  :: String,+	-- | "foo"+	_lsName  :: String,+	-- | "shot-foo/foo.jpg"+	_lsPict  :: String,+	-- | Challenge mode scores: best times (hard, medium, easy), most coins (hard, medium easy).+	_lsChallengeModeScores :: ChallengeModeScores,+	-- | ["map-foo/level.sol", …]+	_lsLevels :: [String]+}+	deriving (Eq, Ord, Show)+makeLenses ''LevelSet++data LevelSets = LevelSets {+	-- | Lines of ‘data/sets.txt’.+	-- [‘set-foo.txt’, …]+	_lsExplicitSets :: [String],+	-- | Map of ‘set-foo.txt’ to the level set.+	_lsLevelSets    :: M.Map String LevelSet+}+	deriving (Eq, Ord, Show)+makeLenses ''LevelSets++-- | Get level sets or fail.+getLevelSets :: IBContext' a -> ImmutaballIOF LevelSets+getLevelSets cxt = do+	asets <- BasicIBIOF $ ReadText ((cxt^.ibDirs.ibStaticDataDir) </> "sets.txt") id+	let err ioErr = BasicIBIOF (PutStrLn ("Error: getLevelSets: failed to read data/sets.txt!  Ensure ‘--static-data-dir=’ is set to a compiled neverball data directory.  Error: " ++ (show ioErr)) ()) >> BasicIBIOF ExitFailureBasicIOF+	msets <- Wait asets id+	sets_ <- err ||| return $ msets+	let setPathList = lines $ T.unpack sets_++	levelSets <- M.fromList . zip setPathList <$> mapM (getLevelSet cxt) setPathList+	return $ LevelSets {+		_lsExplicitSets = setPathList,+		_lsLevelSets    = levelSets+	}++-- | Get level set or fail.+--+-- e.g. ‘getLevelSet cxt "set-foo.txt"’+getLevelSet :: IBContext' a -> String -> ImmutaballIOF LevelSet+getLevelSet cxt path = do+	alevelSetContents <- BasicIBIOF $ ReadText (((cxt^.ibDirs.ibStaticDataDir)) </> path) id+	let err ioErr = BasicIBIOF (PutStrLn ("Error: getLevelSet: failed to read data/"++path++"!  Ensure ‘--static-data-dir=’ is set to a compiled neverball data directory.  Error: " ++ (show ioErr)) ()) >> BasicIBIOF ExitFailureBasicIOF+	mlevelSetContents <- Wait alevelSetContents id+	levelSetContents <- err ||| return $ mlevelSetContents++	let mlevelSet = parseLevelSetFile path (T.unpack $ levelSetContents)+	let perr errMsg = BasicIBIOF (PutStrLn ("Error: getLevelSet: failed to parse data/"++path++"!  (But we could read its contents.)  Error: " ++ errMsg) ()) >> BasicIBIOF ExitFailureBasicIOF+	levelSet <- perr ||| return $ mlevelSet+	return levelSet++parseLevelSetFile :: String -> String -> Either String LevelSet+parseLevelSetFile inputName inputContents = show +++ id $ parseLevelSetFile' inputName inputContents++parseLevelSetFile' :: SourceName -> String -> Either ParseError LevelSet+parseLevelSetFile' inputName inputContents = parse levelSetFileParser inputName inputContents++levelSetFileParser :: Parsec String () LevelSet+levelSetFileParser = LevelSet <$>+	line <*>  -- title+	line <*>  -- desc+	line <*>  -- name+	line <*>  -- pict (screenshot)+	challengeModeLine <*>+	(many line <* eof)+	where line = (manyTill anyChar (lookAhead . try $ endOfLine)) <* endOfLine++challengeModeLine :: Parsec String () ChallengeModeScores+challengeModeLine = ChallengeModeScores <$>+	((,,) <$> nat' <*> nat' <*> nat') <*>+	((,,) <$> nat' <*> nat' <*> nat')+	where nat' = (try nat <|> pure 0) <* spaces
+ Immutaball/Ball/Main.hs view
@@ -0,0 +1,14 @@+{-# 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 #-}++-- Main.hs: Immutaball.++{-# LANGUAGE Haskell2010 #-}++module Immutaball.Ball.Main where++import qualified Immutaball.Ball.CLI++main :: IO ()+main = Immutaball.Ball.CLI.main
+ Immutaball/Ball/State/Game.hs view
@@ -0,0 +1,917 @@+{-# 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 #-}++-- 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.++-- * Local utils.
+ Immutaball/Ball/State/LevelSelect.hs view
@@ -0,0 +1,126 @@+{-# 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 #-}++-- LevelSelect.hs.++{-# LANGUAGE Haskell2010 #-}+{-# LANGUAGE Arrows, TemplateHaskell, ScopedTypeVariables #-}++module Immutaball.Ball.State.LevelSelect+	(+		mkLevelSelectState,+		LevelSelectWidget(..), AsLevelSelectWidget(..),+		levelSelectGui,+		levelSelectBaseGui,+		levelSelectButtons+	) where++import Prelude ()+import Immutaball.Prelude++import Control.Arrow+import Control.Exception+import Control.Lens+import Control.Monad+--import Data.Functor.Identity++--import Control.Lens+--import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BL+--import qualified Data.Map as M+import qualified SDL.Raw.Enum as Raw+import System.FilePath++import Immutaball.Ball.LevelSets+import qualified Immutaball.Ball.State.Play as Play+import Immutaball.Share.Context+import Immutaball.Share.Context.Config+import Immutaball.Share.Level.Base+import Immutaball.Share.Level.Parser+import Immutaball.Share.GUI+import Immutaball.Share.ImmutaballIO+import Immutaball.Share.ImmutaballIO.BasicIO+import Immutaball.Share.Math+import Immutaball.Share.State+import Immutaball.Share.State.Context+import Immutaball.Share.Utils+import Immutaball.Share.Wire++-- (Placed at beginning to avoid Template Haskell errors.)+data LevelSelectWidget =+	  LevelSelectRoot+	| BackButton+	| LevelsVstack+	| LevelButton String+	| Anonymous Integer+	deriving (Eq, Ord, Show)+makeClassyPrisms ''LevelSelectWidget++mkLevelSelectState :: LevelSet -> (Either IBContext IBStateContext -> Immutaball) -> Either IBContext IBStateContext -> Immutaball+mkLevelSelectState levelSet mkBack baseCxt0 = closeSecondI . switch . fromImmutaballSingleWith Nothing . openSecondI $ proc (Identity request) -> do+	rec+		cxtLast <- delay cxt0 -< cxt+		cxtn <- requireBasics -< (cxtLast, request)++		--let (levelSet :: LevelSet) = levelSet++		--(guiResponse, cxtnp1) <- mkGUI $ levelSelectGui levelSet -< (GUIDrive request, cxtn)+		(guiResponse, cxtnp1) <- withM (\gui -> second (mkGUI gui) >>> arr snd) (return . fst) -< (levelSelectGui levelSet, (GUIDrive request, cxtn))+		let response = ContinueResponse++		let isEsc  = (const False ||| (== (fromIntegral Raw.SDLK_ESCAPE, True))) . matching _Keybd $ request+		let isBack = isEsc || guiResponse == WidgetAction BackButton++		() <- finishFrame -< (request, cxtnp1)+		cxt <- returnA -< cxtnp1++	-- If a level was selected, parse it.+	let (toLevelPath :: Maybe String) = (const Nothing ||| Just) . matching (_WidgetAction . _LevelButton) $ guiResponse+	let (toLevelPath' :: Maybe String) = ((cxt^.ibContext.ibDirs.ibStaticDataDir) </>) <$> toLevelPath+	(mtoLevelContents :: Maybe (Either IOException BL.ByteString)) <- monadic -< maybe (pure Nothing) (\path -> (Just <$>) . liftIBIO . BasicIBIOF $ ReadBytesSync path id) $ toLevelPath'+	(toLevelContents :: Maybe BL.ByteString) <- monadic -< maybe (pure Nothing) (\mcontents -> liftIBIO . ThrowIO ||| pure . Just $ mcontents) $ mtoLevelContents+	let (toLevelParse :: Maybe (Either LevelIBParseException LevelIB)) = parseLevelFile' <$> toLevelPath <*> toLevelContents+	(toLevel :: Maybe LevelIB) <- monadic -< maybe (pure Nothing) (liftIBIO . ThrowIO ||| pure . Just) $ toLevelParse+	let (toLevelPathLevel :: Maybe (String, LevelIB)) = (,) <$> toLevelPath <*> toLevel++	-- Switch to a level.+	let switchTo0 = flip fmap toLevelPathLevel $ \(levelPath, level) -> openSecondI $ Play.mkPlayState (Just levelSet) levelPath level (mkLevelSelectState levelSet mkBack) (Right cxt)+	{-+	let switchTo0 = flip fmap toLevel $ \level -> openSecondI $ Play.mkPlayState levelSet level (mkLevelSelectState levelSet mkBack) (Right cxt)+	{-+	let switchTo0 = if' (isJust toLevel) Nothing   . Just . openSecondI $ mkPlayState levelSet level (mkLevelSelectState levelSet mkBack) (Right cxt)+	-}+	-}+	-- Switch on Back button.+	let switchTo  = if' (not    isBack ) switchTo0 . Just . openSecondI $ mkBack (Right cxt)+	returnA -< (Identity response, switchTo)++	where+		cxt0 = either initialStateCxt id baseCxt0+		useUnsafeVersion = False+		parseLevelFile' = if' useUnsafeVersion (\p -> unsafeParseLevelFileRaw p . BL.toStrict) parseLevelFile++-- TODO: make a better UI.  For now we just have a simple list of levels.++levelSelectGui :: LevelSet -> [Widget LevelSelectWidget]+levelSelectGui levelSet =+	levelSelectBaseGui +++	levelSelectButtons levelSet++levelSelectBaseGui :: [Widget LevelSelectWidget]+levelSelectBaseGui =+	[+		RootWidget   $ Root   { _rootWid   = LevelSelectRoot                                },+		ButtonWidget $ Button { _buttonWid = BackButton, _buttonWparent = LevelSelectRoot,+			_buttonText = "Back", _buttonRect = Just $ Rect (Vec2 (-0.800) (0.720)) (Vec2 (-0.700) (0.800)) },+		VstackWidget $ Vstack { _vstackWid = LevelsVstack, _vstackWparent = LevelSelectRoot }+	]++levelSelectButtons :: LevelSet -> [Widget LevelSelectWidget]+levelSelectButtons levelSet = flip map (zip [0..] (levelSet^.lsLevels)) $ \((idx :: Integer), path) ->+	let (r, c) = join (***) fromIntegral $ idx `divMod` 5 in+	ButtonWidget $ Button { _buttonWid = LevelButton path, _buttonWparent = LevelsVstack,+		_buttonText = "Level", _buttonRect = Just $ Rect (Vec2 (-0.165 + c*0.070) (0.160 - r*0.100)) (Vec2 (-0.115 + c*0.070) (0.240 - r*0.100)) }++--makeClassyPrisms ''LevelSelectWidget
+ Immutaball/Ball/State/LevelSets.hs view
@@ -0,0 +1,99 @@+{-# 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 #-}++-- LevelSets.hs.++{-# LANGUAGE Haskell2010 #-}+{-# LANGUAGE Arrows, TemplateHaskell, ScopedTypeVariables #-}++module Immutaball.Ball.State.LevelSets+	(+		mkLevelSetsState,+		LevelSetsWidget(..), AsLevelSetsWidget(..),+		levelSetsGui,+		levelSetsBaseGui,+		levelSetsButtons+	) where++import Prelude ()+import Immutaball.Prelude++import Control.Applicative+import Control.Arrow+import Data.Functor.Identity+import Data.Maybe++import Control.Lens+import qualified Data.Map as M+import qualified SDL.Raw.Enum as Raw++import Immutaball.Ball.LevelSets+import qualified Immutaball.Ball.State.LevelSelect as LevelSelect+import Immutaball.Share.GUI+import Immutaball.Share.Math+import Immutaball.Share.State+import Immutaball.Share.State.Context+import Immutaball.Share.Utils+import Immutaball.Share.Wire++mkLevelSetsState :: (Either IBContext IBStateContext -> Immutaball) -> Either IBContext IBStateContext -> Immutaball+mkLevelSetsState mkBack baseCxt0 = closeSecondI . switch . fromImmutaballSingleWith Nothing . openSecondI $ proc (Identity request) -> do+	rec+		cxtLast <- delay cxt0 -< cxt+		cxtn <- requireBasics -< (cxtLast, request)++		(levelSets :: LevelSets) <- initial -< liftIBIO $ getLevelSets (cxtn^.ibContext)++		--(guiResponse, cxtnp1) <- mkGUI $ levelSetsGui levelSets -< (GUIDrive request, cxtn)+		(guiResponse, cxtnp1) <- withM (\gui -> second (mkGUI gui) >>> arr snd) (return . fst) -< (levelSetsGui levelSets, (GUIDrive request, cxtn))+		let response = ContinueResponse++		let isEsc  = (const False ||| (== (fromIntegral Raw.SDLK_ESCAPE, True))) . matching _Keybd $ request+		let isBack = isEsc || guiResponse == WidgetAction BackButton++		() <- finishFrame -< (request, cxtnp1)+		cxt <- returnA -< cxtnp1++	-- Switch on Back button.+	let switchTo0 = if' (not isBack) Nothing . Just . openSecondI $ mkBack (Right cxt)+	let onSet levelSetPath = flip M.lookup (levelSets^.lsLevelSets) levelSetPath >>= \levelSet -> return . openSecondI $ LevelSelect.mkLevelSelectState levelSet (mkLevelSetsState mkBack) (Right cxt)+	let switchTo = switchTo0 <|> case guiResponse of (WidgetAction (LevelSetButton levelSetPath)) -> onSet levelSetPath; _ -> Nothing+	returnA -< (Identity response, switchTo)++	where cxt0 = either initialStateCxt id baseCxt0++data LevelSetsWidget =+	  LevelSetsRoot+	| BackButton+	| LevelSetsVstack+	| LevelSetButton String+	| Anonymous Integer+	deriving (Eq, Ord, Show)+--makeClassyPrisms ''LevelSetsWidget++-- TODO: make a better UI.  For now we just have a simple list of level set titles.++levelSetsGui :: LevelSets -> [Widget LevelSetsWidget]+levelSetsGui levelSets =+	levelSetsBaseGui +++	levelSetsButtons levelSets++levelSetsBaseGui :: [Widget LevelSetsWidget]+levelSetsBaseGui =+	[+		RootWidget   $ Root   { _rootWid   = LevelSetsRoot                               },+		ButtonWidget $ Button { _buttonWid = BackButton, _buttonWparent = LevelSetsRoot,+			_buttonText = "Back", _buttonRect = Just $ Rect (Vec2 (-0.800) (0.720)) (Vec2 (-0.700) (0.800)) },+		VstackWidget $ Vstack { _vstackWid = LevelSetsVstack, _vstackWparent = LevelSetsRoot  }+	]++levelSetsButtons :: LevelSets -> [Widget LevelSetsWidget]+-- Preserve order.+--levelSetsButtons levelSets = flip map (zip [0..] . M.toList $ levelSets^.lsLevelSets) $ \((idx :: Integer), (path, levelSet)) ->+levelSetsButtons levelSets = catMaybes . flip map (zip [0..] (levelSets^.lsExplicitSets)) $ \((idx :: Integer), path) -> flip fmap (M.lookup path (levelSets^.lsLevelSets)) $ \levelSet ->+	let idx' = fromIntegral idx in+	ButtonWidget $ Button { _buttonWid = LevelSetButton path, _buttonWparent = LevelSetsVstack,+		_buttonText = (levelSet^.lsTitle), _buttonRect = Just $ Rect (Vec2 (-0.100) (0.620 - 0.100*idx')) (Vec2 (0.100) (0.700 - 0.100*idx')) }++makeClassyPrisms ''LevelSetsWidget
+ Immutaball/Ball/State/Play.hs view
@@ -0,0 +1,126 @@+{-# 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 #-}++-- Play.hs.++{-# LANGUAGE Haskell2010 #-}+{-# LANGUAGE Arrows, TemplateHaskell, ScopedTypeVariables #-}++module Immutaball.Ball.State.Play+	(+		mkPlayState,+		PlayWidget(..), AsPlayWidget(..),+		playGui+	) where++import Prelude ()+import Immutaball.Prelude++import Control.Arrow+import Control.Lens+import Control.Monad+--import Data.Functor.Identity++--import Control.Lens+--import Data.Array.IArray+--import qualified Data.Map as M+import qualified SDL.Raw.Enum as Raw++import Immutaball.Ball.Game+import Immutaball.Ball.LevelSets+import Immutaball.Ball.State.Game+import Immutaball.Share.Context+import Immutaball.Share.GUI+import Immutaball.Share.ImmutaballIO.SDLIO+import Immutaball.Share.Level+import Immutaball.Share.Math+import Immutaball.Share.SDLManager+import Immutaball.Share.State+import Immutaball.Share.State.Context+import Immutaball.Share.Utils+import Immutaball.Share.Wire++-- TODO:+mkPlayState :: Maybe LevelSet -> String -> LevelIB -> (Either IBContext IBStateContext -> Immutaball) -> Either IBContext IBStateContext -> Immutaball+mkPlayState mlevelSet levelPath level mkBack baseCxt0 = closeSecondI . switch . fromImmutaballSingleWith Nothing . openSecondI $ proc (Identity request) -> do+	rec+		cxtLast <- delay cxt0 -< cxt+		cxtn <- requireBasics -< (cxtLast, request)++		let sdlh = cxtn^.ibContext.ibSDLManagerHandle++		-- Capture mouse on entry (TODO: only capture when actively playing, not paused or in intermession).+		isFirst <- delay True -< False+		() <- monadic -< if' (not $ isFirst) (return ()) . void . liftIBIO $ sdl sdlh (SDLSetRelativeMouseMode True id)++		-- GUI: don't process here quite yet, only because our overall rendering+		-- plan requires the scene to render first, before GUI.++		-- Set up and step the game.+		-- TODO: implement hasLevelBeenCompleted bool for initialGameState call.  Just setting to False in the meantime.+		let theInitialGameState = initialGameState (cxtn^.ibContext) (cxtn^.ibNeverballrc) False mlevelSet levelPath level+		--lastGameState <- delay theInitialGameState -< gameState+		lastGameState <- delayWith -< (gameState, theInitialGameState)+		(GameResponse _gameEvents gameState cxtnp1) <- stepGame -< GameRequest request lastGameState cxtn+		let gameStateAnalysis = mkGameStateAnalysis cxtnp1 gameState++		-- If playing, prepare the clock to display.  TODO: more than seconds.+		let (timeElapsed :: Double) = gameState^.gsTimeElapsed+		let (secondsElapsed :: Integer) = floor $ timeElapsed+		lastSecondsElapsed <- delay 0 -< secondsElapsed+		let (newClockSeconds :: Maybe Integer) = if' (secondsElapsed /= lastSecondsElapsed) (Just secondsElapsed) Nothing+		let (guiClockInputs :: [WidgetRequest PlayWidget]) = case newClockSeconds of+			Nothing -> []+			Just s  -> [GUISetText ClockLabel (show s) defaultSetTextOptions]++		-- Render the scene.+		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))++		-- GUI.  Positioned after scene rendering.+		--(_guiResponse, cxtnp4) <- mkGUI playGui -< (GUIDrive request, cxtnp3)+		let guiInputs = concat $+			[ guiClockInputs+			]+		(_guiResponses, cxtnp4) <- multistepFeedbackList $ mkGUI playGui -< (GUIDrive request : guiInputs, cxtnp3)+		let response = ContinueResponse++		let isEsc  = (const False ||| (== (fromIntegral Raw.SDLK_ESCAPE, True))) . matching _Keybd $ request+		let isBack = isEsc++		-- Release mouse on isEsc or isBack.+		() <- monadic -< if' (not (isEsc || isBack)) (return ()) . void . liftIBIO $ sdl sdlh (SDLSetRelativeMouseMode False id)++		() <- finishFrame -< (request, cxtnp4)+		cxt <- returnA -< cxtnp4++	-- Switch on Back button.+	let switchTo = if' (not isBack) Nothing . Just . openSecondI $ mkBack (Right cxt)+	returnA -< (Identity response, switchTo)++	where cxt0 = either initialStateCxt id baseCxt0++data PlayWidget =+	  PlayRoot+	| StatusLabel+	| ClockLabel+	| Anonymous Integer+	deriving (Eq, Ord, Show)+--makeClassyPrisms ''PlayWidget++-- TODO:+playGui :: [Widget PlayWidget]+playGui =+	[+		RootWidget $ Root { _rootWid = PlayRoot },++		LabelWidget $ Label { _labelWid = StatusLabel, _labelWparent = PlayRoot,+			_labelText = "", _labelRect = Just $ Rect (Vec2 (-0.100) (-0.040)) (Vec2 (0.100) ( 0.040)) },+		LabelWidget $ Label { _labelWid = ClockLabel, _labelWparent = PlayRoot,+			_labelText = "", _labelRect = Just $ Rect (Vec2 ( 0.750) (-0.870)) (Vec2 (0.950) (-0.950)) }+	]++makeClassyPrisms ''PlayWidget
+ Immutaball/Ball/State/Preplay.hs view
@@ -0,0 +1,73 @@+{-# 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 #-}++-- Play.hs.++{-# LANGUAGE Haskell2010 #-}+{-# LANGUAGE Arrows, TemplateHaskell, ScopedTypeVariables #-}++module Immutaball.Ball.State.Preplay+	(+		mkPreplayState,+		PreplayWidget(..), AsPreplayWidget(..),+		preplayGui+	) where++import Prelude ()+import Immutaball.Prelude++import Control.Arrow+import Control.Lens+--import Control.Monad+--import Data.Functor.Identity++--import Control.Lens+--import qualified Data.Map as M+import qualified SDL.Raw.Enum as Raw++import Immutaball.Ball.LevelSets+import Immutaball.Share.GUI+import Immutaball.Share.Level+--import Immutaball.Share.Math+import Immutaball.Share.State+import Immutaball.Share.State.Context+import Immutaball.Share.Utils+import Immutaball.Share.Wire++-- TODO:+mkPreplayState :: LevelSet -> LevelIB -> (Either IBContext IBStateContext -> Immutaball) -> Either IBContext IBStateContext -> Immutaball+mkPreplayState _levelSet _level mkBack baseCxt0 = closeSecondI . switch . fromImmutaballSingleWith Nothing . openSecondI $ proc (Identity request) -> do+	rec+		cxtLast <- delay cxt0 -< cxt+		cxtn <- requireBasics -< (cxtLast, request)++		(_guiResponse, cxtnp1) <- mkGUI preplayGui -< (GUIDrive request, cxtn)+		let response = ContinueResponse++		let isEsc  = (const False ||| (== (fromIntegral Raw.SDLK_ESCAPE, True))) . matching _Keybd $ request+		let isBack = isEsc++		() <- finishFrame -< (request, cxtnp1)+		cxt <- returnA -< cxtnp1++	-- Switch on Back button.+	let switchTo = if' (not isBack) Nothing . Just . openSecondI $ mkBack (Right cxt)+	returnA -< (Identity response, switchTo)++	where cxt0 = either initialStateCxt id baseCxt0++data PreplayWidget =+	  PreplayRoot+	| Anonymous Integer+	deriving (Eq, Ord, Show)+--makeClassyPrisms ''PreplayWidget++-- TODO:+preplayGui :: [Widget PreplayWidget]+preplayGui =+	[+		RootWidget $ Root { _rootWid = PreplayRoot }+	]++makeClassyPrisms ''PreplayWidget
+ Immutaball/Ball/State/Title.hs view
@@ -0,0 +1,76 @@+{-# 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 #-}++-- State.hs.++{-# LANGUAGE Haskell2010 #-}+{-# LANGUAGE Arrows, TemplateHaskell #-}++module Immutaball.Ball.State.Title+	(+		mkTitleState,+		TitleWidget(..), AsTitleWidget(..),+		titleGui+	) where++import Prelude ()+import Immutaball.Prelude++import Control.Arrow+import Control.Lens+--import Data.Functor.Identity++import qualified SDL.Raw.Enum as Raw++import qualified Immutaball.Ball.State.LevelSets as LevelSets+import Immutaball.Share.GUI+import Immutaball.Share.Math+import Immutaball.Share.State+import Immutaball.Share.State.Context+import Immutaball.Share.Utils+import Immutaball.Share.Wire++mkTitleState :: Either IBContext IBStateContext -> Immutaball+mkTitleState baseCxt0 = closeSecondI . switch . fromImmutaballSingleWith Nothing . openSecondI $ proc (Identity request) -> do+	rec+		cxtLast <- delay cxt0 -< cxt+		cxtn <- requireBasics -< (cxtLast, request)++		(guiResponse, cxtnp1) <- mkGUI titleGui -< (GUIDrive request, cxtn)+		response0 <- returnA -< case guiResponse of+			NoWidgetAction          -> ContinueResponse+			WidgetAction QuitButton -> DoneResponse+			_                       -> ContinueResponse+		response <- returnA -< if' ((const False ||| (== (fromIntegral Raw.SDLK_ESCAPE, True))) . matching _Keybd $ request) DoneResponse response0++		() <- finishFrame -< (request, cxtnp1)+		cxt <- returnA -< cxtnp1++	-- Switch on Play button.+	let switchTo = if' (guiResponse /= WidgetAction PlayButton) Nothing . Just . openSecondI $ LevelSets.mkLevelSetsState mkTitleState (Right cxt)+	returnA -< (Identity response, switchTo)++	where cxt0 = either initialStateCxt id baseCxt0++data TitleWidget =+	  TitleRoot+	| MenuVstack+	| PlayButton+	| QuitButton+	| Anonymous Integer+	deriving (Eq, Ord, Show)+--makeClassyPrisms ''TitleWidget++titleGui :: [Widget TitleWidget]+titleGui =+	[+		RootWidget   $ Root   { _rootWid   = TitleRoot                               },+		VstackWidget $ Vstack { _vstackWid = MenuVstack, _vstackWparent = TitleRoot  },+		ButtonWidget $ Button { _buttonWid = PlayButton, _buttonWparent = MenuVstack,+			_buttonText = "Play", _buttonRect = Just $ Rect (Vec2 (-0.100) ( 0.010)) (Vec2 (0.100) ( 0.090)) },+		ButtonWidget $ Button { _buttonWid = QuitButton, _buttonWparent = MenuVstack,+			_buttonText = "Quit", _buttonRect = Just $ Rect (Vec2 (-0.100) (-0.090)) (Vec2 (0.100) (-0.010)) }+	]++makeClassyPrisms ''TitleWidget
+ Immutaball/Prelude.hs view
@@ -0,0 +1,20 @@+{-# 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 #-}++-- State.hs.++{-# LANGUAGE Haskell2010 #-}++module Immutaball.Prelude+	(+		module Prelude,+		module Control.Category+	) where++-- Prelude imports+import Prelude hiding (id, (.))+--import qualified Prelude++-- base import+import Control.Category
+ Immutaball/Putt/CLI.hs view
@@ -0,0 +1,238 @@+{-# 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 #-}++module Immutaball.Putt.CLI+	(+		main,+		immutaballMain,+		immutaballCLIMain',+		immutaballCLIMain,+		mainImmutaballIO',+		mainImmutaballIO,+		immutaballOptions,+		immutaballWithArgs,+		immutaballHelp,+		immutaballVersion,+		immutaballWithCLIConfig,+		cliIBDirs,+		getDefaultIBDirs,+		immutaballWithCLIConfig',+		immutaballWithNeverballrc,+		immutaballWithContext+	) where++-- Prelude imports+import Prelude ()+import Immutaball.Prelude++-- base imports+import Control.Arrow+import Data.List+import System.Console.GetOpt+import Text.Printf++-- external imports+import Control.Lens+import qualified Data.Text as T+import System.FilePath++-- internal imports+import Immutaball.Ball.CLI.Config+import Immutaball.Share.Config+import Immutaball.Share.Config.Parser+import Immutaball.Share.Config.Printer+import Immutaball.Share.Context+import Immutaball.Share.Context.Config+import Immutaball.Share.ImmutaballIO+import Immutaball.Share.ImmutaballIO.BasicIO+import Immutaball.Share.State+import Immutaball.Share.Utils++main :: IO ()+main = immutaballMain++immutaballMain :: IO ()+immutaballMain = immutaballCLIMain'++immutaballCLIMain' :: IO ()+immutaballCLIMain' = immutaballCLIMain defaultStaticConfig++immutaballCLIMain :: StaticConfig -> IO ()+immutaballCLIMain x'cfg = do+	runImmutaballIO (mainImmutaballIO x'cfg)++mainImmutaballIO' :: ImmutaballIO+mainImmutaballIO' = mainImmutaballIO defaultStaticConfig++mainImmutaballIO :: StaticConfig -> ImmutaballIO+mainImmutaballIO x'cfg =+	mkBIO . GetArgsSync $ immutaballWithArgs x'cfg++immutaballOptions :: [OptDescr CLIConfigBuilder]+immutaballOptions =+	[+		Option ['H', '?'] ["help"]       (NoArg . b $ cliCfgHelp    .~ True)+			"Show help and exit",+		Option []         ["no-help"]    (NoArg . b $ cliCfgHelp    .~ False)+			"",+		Option ['V']      ["version"]    (NoArg . b $ cliCfgVersion .~ True)+			"Show version and exit",+		Option []         ["no-version"] (NoArg . b $ cliCfgVersion .~ False)+			"",++		Option ['d'] ["static-data-dir", "data"] (ReqArg (\path -> b $ cliCfgStaticDataDir .~ Just path) "")+			"Set static data directory path",+		Option []    ["user-data-dir"]           (ReqArg (\path -> b $ cliCfgUserDataDir   .~ Just path) "")+			"Set user data directory path",+		Option []    ["user-config-dir"]         (ReqArg (\path -> b $ cliCfgUserConfigDir .~ Just path) "")+			"Set user config directory path",++		Option [] ["no-static-data-dir"] (NoArg . b $ cliCfgStaticDataDir .~ Nothing)+			"",+		Option [] ["no-user-data-dir"]   (NoArg . b $ cliCfgUserDataDir   .~ Nothing)+			"",+		Option [] ["no-user-config-dir"] (NoArg . b $ cliCfgUserConfigDir .~ Nothing)+			"",++		Option [] ["headless"] (NoArg . b $ cliCfgHeadless .~ True)+			"",+		Option [] ["no-headless"] (NoArg . b $ cliCfgHeadless .~ False)+			""+	]+	where b = CLIConfigBuilder++immutaballWithArgs :: StaticConfig -> [String] -> ImmutaballIO+immutaballWithArgs x'cfg args =+	result+	where+		opts :: [CLIConfigBuilder]+		nonopts, errs :: [String]+		(opts, nonopts, errs) = getOpt Permute immutaballOptions args+		cliCfg = buildCLIConfig (mconcat opts)+		showErrs :: [String] -> ImmutaballIO+		showErrs errs_ = foldr (<>>) mempty $ showErr <$> errs_+		showErr :: String -> ImmutaballIO+		showErr errMsg = mkBIO . PutStrLn (printf "Error: CLI getOpt error: %s" errMsg) $ mkBIO ExitFailureBasicIOF+		result :: ImmutaballIO+		result+			| (not . null) errs    = showErrs errs <>> mkBIO ExitFailureBasicIOF+			| (not . null) nonopts = showErrs $ map (\nonopt -> printf "nonoptions currently not supported; received nonoption ‘%s’" nonopt) nonopts+			| otherwise            = immutaballWithCLIConfig x'cfg cliCfg++immutaballHelp :: String+immutaballHelp = intercalate "\n" $+	[+		"Usage: immutaputt [options…]",+		"",+		"Options:",+		"\t--help: Show usage and exit.",+		"\t--version: Show version and exit.",+		"\t-d PATH, --data PATH, --static-data-dir PATH:",+		"\t\tSet static data directory path.",+		"\t--user-data-dir PATH:",+		"\t\tSet user data directory path.",+		"\t--user-config-dir PATH:",+		"\t\tSet user config directory path.",+		"\t--headless:",+		"\t\tDisable video and audio.  Useful for automated testing."+	]++immutaballVersion :: String+immutaballVersion = "0.1.0.4.1-hackage"++-- | Run immutaball.+immutaballWithCLIConfig :: StaticConfig -> CLIConfig -> ImmutaballIO+immutaballWithCLIConfig x'cfg cliCfg =+	result+	where+		showHelp :: ImmutaballIO+		showHelp = mkBIO . PutStrLn immutaballHelp $ mkBIO ExitSuccessBasicIOF+		showVersion :: ImmutaballIO+		showVersion = mkBIO . PutStrLn immutaballVersion $ mkBIO ExitSuccessBasicIOF+		result :: ImmutaballIO+		result+			| cliCfg^.cliCfgHelp    = showHelp+			| cliCfg^.cliCfgVersion = showVersion+			| otherwise             = immutaballWithCLIConfig' x'cfg cliCfg++cliIBDirs :: CLIConfig -> IBDirs -> IBDirs+cliIBDirs cliCfg defaultIBDirs = IBDirs {+	_ibStaticDataDir = maybe (defaultIBDirs^.ibStaticDataDir) id (cliCfg^.cliCfgStaticDataDir),+	_ibUserDataDir   = maybe (defaultIBDirs^.ibUserDataDir)   id (cliCfg^.cliCfgUserDataDir),+	_ibUserConfigDir = maybe (defaultIBDirs^.ibUserConfigDir) id (cliCfg^.cliCfgUserConfigDir)+}++getDefaultIBDirs :: StaticConfig -> (IBDirs -> ImmutaballIO) -> ImmutaballIO+getDefaultIBDirs x'cfg withIBDirs =+	either (\d f -> mkBIO . DirectoryIO . fmap f $ d) (&) (x'cfg^.defaultStaticDataDir) $ \defaultStaticDataDir_ ->+	either (\d f -> mkBIO . DirectoryIO . fmap f $ d) (&) (x'cfg^.defaultUserDataDir)   $ \defaultUserDataDir_ ->+	either (\d f -> mkBIO . DirectoryIO . fmap f $ d) (&) (x'cfg^.defaultUserConfigDir) $ \defaultUserConfigDir_ ->+	withIBDirs $ IBDirs {+		_ibStaticDataDir = defaultStaticDataDir_,+		_ibUserDataDir   = defaultUserDataDir_,+		_ibUserConfigDir = defaultUserConfigDir_+	}++-- | Run immutaball after basic setup like checking for ‘--help’.+immutaballWithCLIConfig' :: StaticConfig -> CLIConfig -> ImmutaballIO+immutaballWithCLIConfig' x'cfg cliCfg =+	result+	where+		result :: ImmutaballIO+		result = getDefaultIBDirs x'cfg withDefaultIBDirs+		withDefaultIBDirs :: IBDirs -> ImmutaballIO+		withDefaultIBDirs defaultIBDirs = result_+			where+				result_ :: ImmutaballIO+				result_ = createUserDirsIfMissing <>> (mkBIO . DoesPathExistSync neverballrcPath $ withNeverballrcExists)+				createUserDirsIfMissing :: ImmutaballIO+				createUserDirsIfMissing = mconcat . map (mkBIO . flip CreateDirectoryIfMissing mempty) $ [ibDirs_^.ibUserDataDir, ibDirs_^.ibUserConfigDir]+				ibDirs_ :: IBDirs+				ibDirs_ = cliIBDirs cliCfg defaultIBDirs+				neverballrcPath :: FilePath+				neverballrcPath = (ibDirs_^.ibUserConfigDir) </> (x'cfg^.configFilename)+				writeDefaultNeverballrc :: ImmutaballIO+				writeDefaultNeverballrc = mkBIO $ WriteText neverballrcPath (T.pack . showNeverballrc $ defaultNeverballrc) mempty+				defaultNeverballrc :: Neverballrc+				defaultNeverballrc = defaultConfig+				withNeverballrcExists :: Bool -> ImmutaballIO+				withNeverballrcExists False = writeDefaultNeverballrc <>> withNeverballrcExists True+				withNeverballrcExists True = result_2+					where+						result_2 :: ImmutaballIO+						result_2 = mkBIO . ReadTextSync neverballrcPath . (mkThrowIO |||) $ \neverballrcContents -> withParse $ parseNeverballrc neverballrcPath (T.unpack neverballrcContents)+						withParse :: Either String Neverballrc -> ImmutaballIO+						withParse (Left  parseError)   = mkBIO . PutStrLn (printf "Error: failed to parse neverballrc: %s" parseError) $ mkBIO ExitFailureBasicIOF+						withParse (Right neverballrc_) = immutaballWithNeverballrc x'cfg cliCfg ibDirs_ neverballrc_++--- | Run immutaball after getting neverballrc and dirs.+immutaballWithNeverballrc :: StaticConfig -> CLIConfig -> IBDirs -> Neverballrc -> ImmutaballIO+immutaballWithNeverballrc x'cfg cliCfg ibDirs_ nrcCfg =+	result+	where+		result :: ImmutaballIO+		result = withSDL cxtCfg immutaballWithContext+		cxtCfg :: ContextConfig+		cxtCfg = ContextConfig {+			_cxtCfgStaticConfig = x'cfg,+			_cxtCfgDirs         = ibDirs_,+			_cxtCfgNeverballrc  = nrcCfg,+			_cxtCfgInitialWire  = joinMaybeResult $ (x'cfg^.x'cfgInitialWireWithCxt),+			_cxtCfgHeadless     = (cliCfg^.cliCfgHeadless),++			_cxtCfgUseExistingSDLManager = (x'cfg^.x'cfgUseExistingSDLManager),+			_cxtCfgUseExistingGLManager  = (x'cfg^.x'cfgUseExistingGLManager)+		}++--- | Run immutaball after setting up an immutaball context.+immutaballWithContext :: IBContext -> ImmutaballIO+immutaballWithContext _cxt0 =+	result+	where+		result :: ImmutaballIO+		result = mkBIO . PutStrLn "Internal error: unimplemented." $ mkBIO ExitFailureBasicIOF
+ Immutaball/Putt/CLI/Config.hs view
@@ -0,0 +1,55 @@+{-# 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 #-}++-- State.hs.++{-# LANGUAGE Haskell2010 #-}+{-# LANGUAGE TemplateHaskell, InstanceSigs #-}++module Immutaball.Putt.CLI.Config+	(+		CLIConfig(..), cliCfgHelp, cliCfgVersion, cliCfgStaticDataDir,+			cliCfgUserDataDir, cliCfgUserConfigDir, cliCfgHeadless,+		defaultCLIConfig,+		CLIConfigBuilder(..), modifyCLIConfig,+		buildCLIConfig+	) where++import Prelude ()+import Immutaball.Prelude++import Control.Lens++data CLIConfig = CLIConfig {+	_cliCfgHelp          :: Bool,+	_cliCfgVersion       :: Bool,+	_cliCfgStaticDataDir :: Maybe FilePath,+	_cliCfgUserDataDir   :: Maybe FilePath,+	_cliCfgUserConfigDir :: Maybe FilePath,+	_cliCfgHeadless      :: Bool+}+	deriving (Eq, Ord)+makeLenses ''CLIConfig++defaultCLIConfig :: CLIConfig+defaultCLIConfig = CLIConfig {+	_cliCfgHelp          = False,+	_cliCfgVersion       = False,+	_cliCfgStaticDataDir = Nothing,+	_cliCfgUserDataDir   = Nothing,+	_cliCfgUserConfigDir = Nothing,+	_cliCfgHeadless      = False+}++newtype CLIConfigBuilder = CLIConfigBuilder {_modifyCLIConfig :: CLIConfig -> CLIConfig}+makeLenses ''CLIConfigBuilder++instance Semigroup CLIConfigBuilder where+	(<>) :: CLIConfigBuilder -> CLIConfigBuilder -> CLIConfigBuilder+	a <> b = CLIConfigBuilder $ (b^.modifyCLIConfig) . (a^.modifyCLIConfig)+instance Monoid CLIConfigBuilder where+	mempty = CLIConfigBuilder $ id++buildCLIConfig :: CLIConfigBuilder -> CLIConfig+buildCLIConfig builder = (builder^.modifyCLIConfig) defaultCLIConfig
+ Immutaball/Putt/Main.hs view
@@ -0,0 +1,14 @@+{-# 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 #-}++-- Main.hs: Immutaball.++{-# LANGUAGE Haskell2010 #-}++module Immutaball.Putt.Main where++import qualified Immutaball.Putt.CLI++main :: IO ()+main = Immutaball.Putt.CLI.main
+ Immutaball/Share/AutoPar.hs view
@@ -0,0 +1,56 @@+{-# 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 #-}++-- State.hs.++{-# LANGUAGE Haskell2010 #-}+{-# LANGUAGE TemplateHaskell, DerivingVia, InstanceSigs #-}++module Immutaball.Share.AutoPar+	(+		AutoPar,+		AutoParT(..), autoParT,+		runAutoParT,+		runAutoPar+	) where++import Prelude ()+import Immutaball.Prelude++import Control.Monad.Fix+import Control.Monad.Trans.Class+import Control.Parallel+import Data.Functor.Identity++import Control.Lens++type AutoPar = AutoParT Identity++-- Possible extension: an ADT with ‘NoAutoPar’ that does not apply extra ‘par’+-- instances.+newtype AutoParT m a = AutoParT { _autoParT :: m a }+	deriving (Eq, Ord, Show, Semigroup, Monoid, Enum, Read, Num, Fractional, Real, RealFrac, Bounded)+		via (m a)+makeLenses ''AutoParT++runAutoParT :: AutoParT m a -> m a+runAutoParT (AutoParT m) = m++runAutoPar :: AutoPar a -> a+runAutoPar (AutoParT (Identity a)) = a++instance (Functor m) => Functor (AutoParT m) where+	fmap f (AutoParT m) = AutoParT (fmap f m)+instance (Applicative m) => Applicative (AutoParT m) where+	pure a = AutoParT (pure a)+	(AutoParT f) <*> (AutoParT a) = f `par` a `par` AutoParT (f <*> a)+instance (Monad m) => Monad (AutoParT m) where+	return = pure+	(AutoParT ma) >>= fmb = AutoParT $ ma `par` fmb `par` (ma >>= _autoParT . fmb)+instance (MonadFix m) => MonadFix (AutoParT m) where+	mfix :: (MonadFix m) => (a -> AutoParT m a) -> AutoParT m a+	mfix f = AutoParT $ mfix (\a -> _autoParT . f $ a)+instance MonadTrans AutoParT where+	lift :: (Monad m) => m a -> AutoParT m a+	lift = AutoParT
+ Immutaball/Share/Config.hs view
@@ -0,0 +1,446 @@+{-# 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 #-}++-- State.hs.++{-# LANGUAGE Haskell2010 #-}+{-# LANGUAGE TemplateHaskell #-}++module Immutaball.Share.Config+	(+		StaticConfig'(..), minClockPeriod, maxClockPeriod, maxFrameEvents,+			allowWireForks, maxStepFrameSize, maxResponseFrameSize,+			defaultStaticDataDir, defaultUserDataDir, defaultUserConfigDir,+			configFilename, x'cfgInitialWireWithCxt, immutaballFont,+			immutaballFontSize, sdlManagerStaticConfig, glManagerStaticConfig,+			x'cfgUseExistingSDLManager, x'cfgUseExistingGLManager,+			x'cfgMaxPassTextures, x'cfgPrecacheMtrls, x'cfgPrecacheMisc,+			x'cfgBallTriangles, x'cfgDebugFreeCamera, x'cfgVertUpKey,+			x'cfgVertDownKey, x'cfgFreeCameraToggleKey, x'glNearVal,+			x'glFarVal, x'cfgDepthScale, x'cfgViewCollapse,+			x'cfgCameraDistance, x'cfgCameraRaisedCircles, x'cfgMaxTilt,+			x'cfgGravity, x'cfgBounceReturn, x'cfgMaxFrameCollisions,+			x'cfgMaxFrameCollisionsDtThreshold,+			x'cfgMaxFrameCollisionsRDistanceThreshold, x'cfgMaxPhysicsStepTime,+		defaultStaticConfig,+		Neverballrc,+		Config(..), fullscreen, display, width, height, stereo, camera,+			textures, reflection, multisample, mipmap, aniso, background,+			shadow, audioBuff, mouseSense, mouseResp, mouseInvert, mouseVsync,+			hmd, highdpi, mouseCamera1, mouseCamera2, mouseCameraToggle,+			mouseCameraL, mouseCameraR, nice, fps, soundVolume, musicVolume,+			joystick, joystickResp, joystickAxisX0, joystickAxisY0,+			joystickAxisX1, joystickAxisY1, joystickAxisX0Invert,+			joystickAxisY0Invert, joystickAxisX1Invert, joystickAxisY1Invert,+			joystickButtonA, joystickButtonB, joystickButtonX, joystickButtonY,+			joystickButtonL1, joystickButtonL2, joystickButtonR1,+			joystickButtonR2, joystickButtonSelect, joystickButtonStart,+			joystickDpadL, joystickDpadR, joystickDpadU, joystickDpadD,+			wiimoteInvertPitch, wiimoteInvertRoll, wiimotePitchSens,+			wiimoteRollSense, wiimoteSmoothAlpha, wiimoteHoldSideways,+			keyCamera1, keyCamera2, keyCamera3, keyCameraToggle, keyCameraR,+			keyCameraL, keyForward, keyBackward, keyLeft, keyRight, keyRestart,+			keyScoreNext, keyRotateFast, viewFov, viewDp, viewDc, viewDz,+			rotateFast, rotateSlow, cheat, stats, screenshot, lockGoals,+			camera1Speed, camera2Speed, camera3Speed, cameraTouchRotate,+			player, ballFile, wiimoteAddr, replayName, language, theme,+		defaultConfig+	) where++import Prelude ()+import Immutaball.Prelude++import Control.Lens+import qualified SDL.Raw.Enum as Raw++import Immutaball.Share.ImmutaballIO.DirectoryIO+import Immutaball.Share.GLManager+import Immutaball.Share.GLManager.Config+import Immutaball.Share.Math (tau)+import Immutaball.Share.SDLManager+import Immutaball.Share.SDLManager.Config++data StaticConfig' initialWireWithCxt = StaticConfig {+	-- | Maximum FPS, including non-clock SDL events.+	_minClockPeriod :: Maybe Double,+	-- | If at least one non-clock event has been stepped, if more SDL+	-- events are available, delay processing those events if at least this+	-- much time has passed.  This might also be known as ‘maxEventPeriod’ with+	-- respect to clock steps.+	_maxClockPeriod :: Maybe Double,+	-- | If a single frame has more than this limit events, drop all after the+	-- first limit tunmber.+	_maxFrameEvents :: Maybe Integer,+	-- | Drop step requests after this many requests if they are all given+	-- at once.  Also do not send more than this many requests in one step.+	_maxStepFrameSize :: Maybe Integer,+	-- | Drop step responses after this many responses if they are all+	-- at once.  Also do not send more than this many responses in one+	-- step.  The wire may opt to priority queue responses exceeding the+	-- capacity if there's a response it doesn't want to drop.+	_maxResponseFrameSize :: Maybe Integer,+	_allowWireForks :: Bool,++	_defaultStaticDataDir :: Either (DirectoryIOF FilePath) FilePath,+	_defaultUserDataDir   :: Either (DirectoryIOF FilePath) FilePath,+	_defaultUserConfigDir :: Either (DirectoryIOF FilePath) FilePath,++	_configFilename :: FilePath,++	_x'cfgInitialWireWithCxt :: Maybe initialWireWithCxt,++	-- | Relative to the static data dir.+	_immutaballFont     :: FilePath,+	_immutaballFontSize :: Integer,++	-- | Use separate records to allow these modules to have their own static+	-- config.+	_sdlManagerStaticConfig :: SDLManagerStaticConfig,+	_glManagerStaticConfig  :: GLManagerStaticConfig,++	-- | Allow tests to share a single manager.+	_x'cfgUseExistingSDLManager :: Maybe SDLManagerHandle,+	_x'cfgUseExistingGLManager  :: Maybe GLManagerHandle,++	-- | How many textures can we use at once in a single call to+	-- 'glDrawElements'?+	_x'cfgMaxPassTextures :: Integer,++	-- | Request a thread is spawned in the background to precache Mtrl.+	_x'cfgPrecacheMtrls :: Bool,+	-- | Request a thread is spawned in the background to do misc precaching+	-- when setting up allocated textures.+	_x'cfgPrecacheMisc :: Bool,++	_x'cfgBallTriangles :: Integer,++	-- | Whether to allow entering debug free camera mode.+	_x'cfgDebugFreeCamera :: Bool,++	-- | Debug free camera: move vertically up and down (e.g. spacebar and c as in jump and crouch).+	_x'cfgVertUpKey           :: Int,+	_x'cfgVertDownKey         :: Int,+	_x'cfgFreeCameraToggleKey :: Int,++	-- | OpenGL without extensions unfortunately doesn't support disabling+	-- clipping by the ‘y’ coordinate (which we swap with the ‘z’ coordinate+	-- for OpenGL depth, so we do this ourselves).  So just set to a large+	-- value with 'glDepthRange'.  The default values are 0 and 1.+	_x'glNearVal :: Double,+	_x'glFarVal  :: Double,++	_x'cfgDepthScale :: Double,+	_x'cfgViewCollapse :: Bool,  -- ^ Whether to use fovPure variant.++	-- | How far Playing camera is from the center of the ball.  World units (which is 64 .map units).+	_x'cfgCameraDistance :: Double,+	-- | Pitch in radians times tau.  By what angle (preserving distance) should the camera be raised relative to level with the ball?  1 circle is 360 degrees and also tau radians.+	_x'cfgCameraRaisedCircles :: Double,++	-- | Maximum tilt angle from neutral.+	_x'cfgMaxTilt :: Double,++	-- | How many meters per second squared is gravitational acceleration?+	_x'cfgGravity :: Double,+	-- | How much of the ball's velocity is kept on a collision?+	_x'cfgBounceReturn :: Double,+	-- | In a single frame, if the physics engine has already detected this+	-- many collisions without a threshold amount of dt being expended, give up+	-- and advance the frame.  This handles the squish physics mechanic.+	_x'cfgMaxFrameCollisions :: Integer,+	-- | For the squish physics mechanic, how much time has to pass before+	-- resetting the collision counter.+	_x'cfgMaxFrameCollisionsDtThreshold :: Double,+	-- | If this much distance (in terms of ball radius) has passed, then also reset the collision counter.+	_x'cfgMaxFrameCollisionsRDistanceThreshold :: Double,+	-- | How far in time to step the physics world at a time, at most.+	-- We only need this because our simplistic physics doesn't properly model+	-- the curves of gravity, but instead adds a sudden burst of gravity onto+	-- the velocity each frame (or collision within a step within a frame),+	-- since without it the line approximations can make the ball get too much+	-- 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+}+makeLenses ''StaticConfig'++-- | Default static config.+defaultStaticConfig :: StaticConfig' a+defaultStaticConfig = StaticConfig {+	_minClockPeriod       = Just 0.001,  -- ^ Max FPS: 1000.+	_maxClockPeriod       = Just 0.5,    -- ^ Don't let external events block the clock for more than 500ms.+	_maxFrameEvents       = Nothing,+	_maxStepFrameSize     = Just 8,      -- ^ Don't request more than 8 at a time.+	_maxResponseFrameSize = Nothing,     -- ^ Don't request more than 8 at a time.+	_allowWireForks       = False,       -- ^ Don't let immutaball signals fork.++	_defaultStaticDataDir = Right "./data",+	_defaultUserDataDir   = Left $ GetXdgDirectoryDataSync "immutaball" id,+	_defaultUserConfigDir = Left $ GetXdgDirectoryConfigSync "immutaball" id,++	_configFilename          = "neverballrc",+	_x'cfgInitialWireWithCxt = Nothing,++	_immutaballFont     = "ttf/DejaVuSans-Bold.ttf",+	_immutaballFontSize = 256,++	_sdlManagerStaticConfig = defaultSDLManagerStaticConfig,+	_glManagerStaticConfig  = defaultGLManagerStaticConfig,++	_x'cfgUseExistingSDLManager = Nothing,+	_x'cfgUseExistingGLManager  = Nothing,++	_x'cfgMaxPassTextures = 16,++	_x'cfgPrecacheMtrls = True,+	_x'cfgPrecacheMisc  = True,++	_x'cfgBallTriangles = 8 * 64,  -- 512++	-- TODO disable again after debugging by setting to False:+	--_x'cfgDebugFreeCamera = False,+	_x'cfgDebugFreeCamera = True,++	_x'cfgVertUpKey   = fromIntegral Raw.SDLK_SPACE,+	_x'cfgVertDownKey = fromIntegral Raw.SDLK_c,+	_x'cfgFreeCameraToggleKey = fromIntegral Raw.SDLK_f,++	_x'glNearVal = 0.0,+	_x'glFarVal  = 9.99e35,++	_x'cfgDepthScale = 1.0e-6,+	_x'cfgViewCollapse = True,++	_x'cfgCameraDistance = 2.0,+	_x'cfgCameraRaisedCircles = (1/4) * (1/3),++	_x'cfgMaxTilt = (20.0/360.00) * tau,++	_x'cfgGravity = 9.8,+	_x'cfgBounceReturn = 0.7,+	_x'cfgMaxFrameCollisions = 1024,                    -- TODO: double check if you think this is a good value for this setting.+	_x'cfgMaxFrameCollisionsDtThreshold = 0.001,        -- TODO: double check if you think this is a good value for this setting.+	_x'cfgMaxFrameCollisionsRDistanceThreshold = 10.0,  -- TODO: double check if you think this is a good value for this setting.+	--_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+}++type Neverballrc = Config+data Config = Config {+	_fullscreen  :: Bool,  -- "fullscreen"     False+	_display     :: Int,   -- "display"        0+	_width       :: Int,   -- "width"          800+	_height      :: Int,   -- "height"         600+	_stereo      :: Bool,  -- "stereo"         False+	_camera      :: Int,   -- "camera"         0+	_textures    :: Bool,  -- "textures"       True+	_reflection  :: Bool,  -- "reflection"     True+	_multisample :: Bool,  -- "multisample"    False+	_mipmap      :: Bool,  -- "mipmap"         True+	_aniso       :: Int,   -- "aniso"          8+	_background  :: Bool,  -- "background"     True+	_shadow      :: Bool,  -- "shadow"         True+	_audioBuff   :: Int,   -- "audio_buff"     2048+	_mouseSense  :: Int,   -- "mouse_sense"    444+	_mouseResp   :: Int,   -- "mouse_response" 50+	_mouseInvert :: Bool,  -- "mouse_invert"   False+	_mouseVsync  :: Bool,  -- "vsync"          True+	_hmd         :: Bool,  -- "hmd"            False+	_highdpi     :: Bool,  -- "highdpi"        True++	_mouseCamera1      :: Int,   -- "mouse_camera_1"      0+	_mouseCamera2      :: Int,   -- "mouse_camera_1"      0+	_mouseCameraToggle :: Int,   -- "mouse_camera_toggle" 2  -- SDL_BUTTON_MIDDLE+	_mouseCameraL      :: Int,   -- "mouse_camera_l"      1  -- SDL_BUTTON_LEFT+	_mouseCameraR      :: Int,   -- "mouse_camera_r"      3  -- SDL_BUTTON_RIGHT++	_nice        :: Int,  -- "nice"         0+	_fps         :: Int,  -- "fps"          0+	_soundVolume :: Int,  -- "sound_volume" 10+	_musicVolume :: Int,  -- "music_volume" 6++	_joystick             :: Bool,  -- "joystick"          True+	_joystickResp         :: Int,   -- "joystick_response" 50+	_joystickAxisX0       :: Int,   -- "joystick_axis_x0"  0+	_joystickAxisY0       :: Int,   -- "joystick_axis_x1"  1+	_joystickAxisX1       :: Int,   -- "joystick_axis_y0"  3+	_joystickAxisY1       :: Int,   -- "joystick_axis_y1"  4+	_joystickAxisX0Invert :: Bool,  -- "joystick_axis_x0"  False+	_joystickAxisY0Invert :: Bool,  -- "joystick_axis_x1"  False+	_joystickAxisX1Invert :: Bool,  -- "joystick_axis_y0"  False+	_joystickAxisY1Invert :: Bool,  -- "joystick_axis_y1"  False++	_joystickButtonA      :: Int,  -- "joystick_button_a"      0+	_joystickButtonB      :: Int,  -- "joystick_button_b"      1+	_joystickButtonX      :: Int,  -- "joystick_button_x"      2+	_joystickButtonY      :: Int,  -- "joystick_button_y"      3+	_joystickButtonL1     :: Int,  -- "joystick_button_l1"     4+	_joystickButtonL2     :: Int,  -- "joystick_button_r1"     5+	_joystickButtonR1     :: Int,  -- "joystick_button_l2"     -1+	_joystickButtonR2     :: Int,  -- "joystick_button_r2"     -1+	_joystickButtonSelect :: Int,  -- "joystick_button_select" 6+	_joystickButtonStart  :: Int,  -- "joystick_button_start"  7+	_joystickDpadL        :: Int,  -- "joystick_dpad_l"        8+	_joystickDpadR        :: Int,  -- "joystick_dpad_r"        9+	_joystickDpadU        :: Int,  -- "joystick_dpad_u"        10+	_joystickDpadD        :: Int,  -- "joystick_dpad_d"        11++	_wiimoteInvertPitch  :: Bool,  -- "wiimote_invert_pitch"      False+	_wiimoteInvertRoll   :: Bool,  -- "wiimote_invert_roll"       False+	_wiimotePitchSens    :: Int,   -- "wiimote_pitch_sensitivity" 100+	_wiimoteRollSense    :: Int,   -- "wiimote_roll_sensitivity"  100+	_wiimoteSmoothAlpha  :: Int,   -- "wiimote_smooth_alpha"      50+	_wiimoteHoldSideways :: Bool,  -- "wiimote_hold_sideways"     False++	_keyCamera1      :: Int,  -- "key_camera_1"      0x31        -- SDLK_1+	_keyCamera2      :: Int,  -- "key_camera_2"      0x32        -- SDLK_2+	_keyCamera3      :: Int,  -- "key_camera_3"      0x33        -- SDLK_3+	_keyCameraToggle :: Int,  -- "key_camera_toggle" 0x65        -- SDLK_e+	_keyCameraR      :: Int,  -- "key_camera_r"      0x64        -- SDLK_d+	_keyCameraL      :: Int,  -- "key_camera_l"      0x6C        -- SDLK_s+	_keyForward      :: Int,  -- "key_forward"       0x40000052  -- SDLK_UP+	_keyBackward     :: Int,  -- "key_backward"      0x40000051  -- SDLK_DOWN+	_keyLeft         :: Int,  -- "key_left"          0x40000050  -- SDLK_LEFT+	_keyRight        :: Int,  -- "key_right"         0x4000004F  -- SDLK_RIGHT+	_keyRestart      :: Int,  -- "key_restart"       0x72        -- SDLK_r+	_keyScoreNext    :: Int,  -- "key_score_next"    0x09        -- SDLK_TAB+	_keyRotateFast   :: Int,  -- "key_rotate_fast"   0x400000E1  -- SDLK_LSHIFT++	_viewFov    :: Int,   -- "view_fov"    50+	_viewDp     :: Int,   -- "view_dp"     75+	_viewDc     :: Int,   -- "view_dc"     25+	_viewDz     :: Int,   -- "view_dz"     200+	_rotateFast :: Int,   -- "rotate_fast" 300+	_rotateSlow :: Int,   -- "rotate_slow" 300+	_cheat      :: Bool,  -- "cheat"       False+	_stats      :: Bool,  -- "stats"       False+	_screenshot :: Bool,  -- "screenshot"  False+	_lockGoals  :: Bool,  -- "lock_goals"  True++	_camera1Speed :: Int,  -- "camera_1_speed" 250+	_camera2Speed :: Int,  -- "camera_2_speed" 0+	_camera3Speed :: Int,  -- "camera_3_speed" -1++	_cameraTouchRotate :: Int,  -- "touch_rotate" 16++	_player      :: String,  -- "player"       ""+	_ballFile    :: String,  -- "ball_file"    "ball/basic-ball/basic-ball"+	_wiimoteAddr :: String,  -- "wiimote_addr" ""+	_replayName  :: String,  -- "replay_name"  "%s-%l"+	_language    :: String,  -- "language"     ""+	_theme       :: String   -- "theme"        "classic"+}+	deriving (Eq, Ord, Show)+makeLenses ''Config++defaultConfig :: Config+defaultConfig = Config {+	_fullscreen  = False,+	_display     = 0,+	_width       = 800,+	_height      = 600,+	_stereo      = False,+	_camera      = 0,+	_textures    = True,+	_reflection  = True,+	_multisample = False,+	_mipmap      = True,+	_aniso       = 8,+	_background  = True,+	_shadow      = True,+	_audioBuff   = 2048,+	_mouseSense  = 444,+	_mouseResp   = 50,+	_mouseInvert = False,+	_mouseVsync  = True,+	_hmd         = False,+	_highdpi     = True,++	_mouseCamera1      = 0,+	_mouseCamera2      = 0,+	_mouseCameraToggle = 2,  -- SDL_BUTTON_MIDDLE+	_mouseCameraL      = 1,  -- SDL_BUTTON_LEFT+	_mouseCameraR      = 3,  -- SDL_BUTTON_RIGHT++	_nice        = 0,+	_fps         = 0,+	_soundVolume = 10,+	_musicVolume = 6,++	_joystick             = True,+	_joystickResp         = 50,+	_joystickAxisX0       = 0,+	_joystickAxisY0       = 1,+	_joystickAxisX1       = 3,+	_joystickAxisY1       = 4,+	_joystickAxisX0Invert = False,+	_joystickAxisY0Invert = False,+	_joystickAxisX1Invert = False,+	_joystickAxisY1Invert = False,++	_joystickButtonA      = 0,+	_joystickButtonB      = 1,+	_joystickButtonX      = 2,+	_joystickButtonY      = 3,+	_joystickButtonL1     = 4,+	_joystickButtonL2     = 5,+	_joystickButtonR1     = -1,+	_joystickButtonR2     = -1,+	_joystickButtonSelect = 6,+	_joystickButtonStart  = 7,+	_joystickDpadL        = 8,+	_joystickDpadR        = 9,+	_joystickDpadU        = 10,+	_joystickDpadD        = 11,++	_wiimoteInvertPitch  = False,+	_wiimoteInvertRoll   = False,+	_wiimotePitchSens    = 100,+	_wiimoteRollSense    = 100,+	_wiimoteSmoothAlpha  = 50,+	_wiimoteHoldSideways = False,++	_keyCamera1      = 0x31,        -- SDLK_1+	_keyCamera2      = 0x32,        -- SDLK_2+	_keyCamera3      = 0x33,        -- SDLK_3+	_keyCameraToggle = 0x65,        -- SDLK_e+	_keyCameraR      = 0x64,        -- SDLK_d+	_keyCameraL      = 0x6C,        -- SDLK_s+	_keyForward      = 0x40000052,  -- SDLK_UP+	_keyBackward     = 0x40000051,  -- SDLK_DOWN+	_keyLeft         = 0x40000050,  -- SDLK_LEFT+	_keyRight        = 0x4000004F,  -- SDLK_RIGHT+	_keyRestart      = 0x72,        -- SDLK_r+	_keyScoreNext    = 0x09,        -- SDLK_TAB+	_keyRotateFast   = 0x400000E1,  -- SDLK_LSHIFT++	_viewFov    = 50,+	_viewDp     = 75,+	_viewDc     = 25,+	_viewDz     = 200,+	_rotateFast = 300,+	_rotateSlow = 300,+	_cheat      = False,+	_stats      = False,+	_screenshot = False,+	_lockGoals  = True,++	_camera1Speed = 250,+	_camera2Speed = 0,+	_camera3Speed = -1,++	_cameraTouchRotate = 16,++	_player      = "",+	_ballFile    = "ball/basic-ball/basic-ball",+	_wiimoteAddr = "",+	_replayName  = "%s-%l",+	_language    = "",+	_theme       = "classic"+}++-- TODO: print and parse.
+ Immutaball/Share/Config/Parser.hs view
@@ -0,0 +1,181 @@+{-# 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 #-}++-- State.hs.++{-# LANGUAGE Haskell2010 #-}++module Immutaball.Share.Config.Parser+	(+		nat,+		boolInt,+		strVal,+		intConf,+		boolConf,+		stringConf,+		neverballrc,+		parseNeverballrc,+		parseNeverballrc',+	) where++import Prelude ()+import Immutaball.Prelude++import Control.Monad++import Text.Parsec+import Text.Read++import Immutaball.Share.Config++nat :: (Integral i) => Parsec String () i+nat = do+	digits <- many1 digit+	let val = readMaybe digits  :: Maybe Integer+	maybe (unexpected "failed to parse nat") return (fromIntegral <$> val)++int :: (Integral i) => Parsec String () i+int = do+	sign0 <- optionMaybe (char '-')+	sign1 <- optionMaybe (char '+')+	let sign0f = maybe id (const negate) sign0+	let sign1f = maybe id (const id)     sign1+	let next | (Nothing, Nothing) <- (sign0, sign1) = nat | otherwise = int+	sign0f . sign1f <$> next++boolInt :: Parsec String () Bool+boolInt = do+	val <- nat+	return (val /= (0 :: Integer))++strVal :: Parsec String () String+strVal = do+	manyTill anyChar (lookAhead . try $ endOfLine)++intConf :: (Integral i) => String -> Parsec String () i+intConf key = do+	string key *> space *> spaces *> int <* endOfLine+boolConf :: String -> Parsec String () Bool+boolConf key = do+	string key *> space *> spaces *> boolInt <* endOfLine+stringConf' :: Bool -> String -> Parsec String () String+stringConf' allowNospaceEol key = do+	--string key *> space' *> spaces *> strVal <* endOfLine+	string key *> space' *> manyTill space (lookAhead . try $ void endOfLine <|> void strVal) *> strVal <* endOfLine+	where space' | not allowNospaceEol = void (notFollowedBy endOfLine *> space) | otherwise = pure ()+stringConf :: String -> Parsec String () String+stringConf = stringConf' True++-- | This simple parser requires the same order.+-- TODO: support out of order.+neverballrc :: Parsec String () Config+neverballrc = Config <$>+	boolConf "fullscreen" <*>+	intConf  "display" <*>+	intConf  "width" <*>+	intConf  "height" <*>+	boolConf "stereo" <*>+	intConf  "camera" <*>+	boolConf "textures" <*>+	boolConf "reflection" <*>+	boolConf "multisample" <*>+	boolConf "mipmap" <*>+	intConf  "aniso" <*>+	boolConf "background" <*>+	boolConf "shadow" <*>+	intConf  "audio_buff" <*>+	intConf  "mouse_sense" <*>+	intConf  "mouse_response" <*>+	boolConf "mouse_invert" <*>+	boolConf "vsync" <*>+	boolConf "hmd" <*>+	boolConf "highdpi" <*>++	intConf  "mouse_camera_1" <*>+	intConf  "mouse_camera_1" <*>+	intConf  "mouse_camera_toggle" <*>+	intConf  "mouse_camera_l" <*>+	intConf  "mouse_camera_r" <*>++	intConf  "nice" <*>+	intConf  "fps" <*>+	intConf  "sound_volume" <*>+	intConf  "music_volume" <*>++	boolConf "joystick" <*>+	intConf  "joystick_response" <*>+	intConf  "joystick_axis_x0" <*>+	intConf  "joystick_axis_x1" <*>+	intConf  "joystick_axis_y0" <*>+	intConf  "joystick_axis_y1" <*>+	boolConf "joystick_axis_x0" <*>+	boolConf "joystick_axis_x1" <*>+	boolConf "joystick_axis_y0" <*>+	boolConf "joystick_axis_y1" <*>++	intConf  "joystick_button_a" <*>+	intConf  "joystick_button_b" <*>+	intConf  "joystick_button_x" <*>+	intConf  "joystick_button_y" <*>+	intConf  "joystick_button_l1" <*>+	intConf  "joystick_button_r1" <*>+	intConf  "joystick_button_l2" <*>+	intConf  "joystick_button_r2" <*>+	intConf  "joystick_button_select" <*>+	intConf  "joystick_button_start" <*>+	intConf  "joystick_dpad_l" <*>+	intConf  "joystick_dpad_r" <*>+	intConf  "joystick_dpad_u" <*>+	intConf  "joystick_dpad_d" <*>++	boolConf "wiimote_invert_pitch" <*>+	boolConf "wiimote_invert_roll" <*>+	intConf  "wiimote_pitch_sensitivity" <*>+	intConf  "wiimote_roll_sensitivity" <*>+	intConf  "wiimote_smooth_alpha" <*>+	boolConf "wiimote_hold_sideways" <*>++	intConf  "key_camera_1" <*>+	intConf  "key_camera_2" <*>+	intConf  "key_camera_3" <*>+	intConf  "key_camera_toggle" <*>+	intConf  "key_camera_r" <*>+	intConf  "key_camera_l" <*>+	intConf  "key_forward" <*>+	intConf  "key_backward" <*>+	intConf  "key_left" <*>+	intConf  "key_right" <*>+	intConf  "key_restart" <*>+	intConf  "key_score_next" <*>+	intConf  "key_rotate_fast" <*>++	intConf  "view_fov" <*>+	intConf  "view_dp" <*>+	intConf  "view_dc" <*>+	intConf  "view_dz" <*>+	intConf  "rotate_fast" <*>+	intConf  "rotate_slow" <*>+	boolConf "cheat" <*>+	boolConf "stats" <*>+	boolConf "screenshot" <*>+	boolConf "lock_goals" <*>++	intConf  "camera_1_speed" <*>+	intConf  "camera_2_speed" <*>+	intConf  "camera_3_speed" <*>++	intConf  "touch_rotate" <*>++	stringConf "player" <*>+	stringConf "ball_file" <*>+	stringConf "wiimote_addr" <*>+	stringConf "replay_name" <*>+	stringConf "language" <*>+	stringConf "theme"++parseNeverballrc :: String -> String -> Either String Config+parseNeverballrc inputName inputContents = either (Left . show) Right $ parseNeverballrc' inputName inputContents++parseNeverballrc' :: SourceName -> String -> Either ParseError Config+parseNeverballrc' inputName inputContents = parse neverballrc inputName inputContents
+ Immutaball/Share/Config/Printer.hs view
@@ -0,0 +1,146 @@+{-# 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 #-}++-- State.hs.++{-# LANGUAGE Haskell2010, RankNTypes #-}++module Immutaball.Share.Config.Printer+	(+		boolToInt,+		showIntConf,+		showBoolConf,+		showStringConf,+		showNeverballrc+	) where++import Prelude ()+import Immutaball.Prelude++import Data.List+import Text.Printf++import Control.Lens++import Immutaball.Share.Config++boolToInt :: (Integral i) => Bool -> i+boolToInt True = fromIntegral (1 :: Integer)+boolToInt False = fromIntegral (0 :: Integer)++showIntConf :: (Integral i, Show i) => Getter Neverballrc i -> String -> Neverballrc -> String+showIntConf field key cfg = printf "%-25s %s" key $ show (cfg^.field)++showBoolConf :: Getter Neverballrc Bool -> String -> Neverballrc -> String+showBoolConf field key cfg = printf "%-25s %s" key $ show (boolToInt $ cfg^.field  :: Integer)++showStringConf :: Getter Neverballrc String -> String -> Neverballrc -> String+showStringConf field key cfg = printf "%-25s %s" key $ cfg^.field++showNeverballrc :: Neverballrc -> String+showNeverballrc cfg = intercalate "\n" . map ($ cfg) $+	[+		showBoolConf fullscreen  "fullscreen",+		showIntConf  display     "display",+		showIntConf  width       "width",+		showIntConf  height      "height",+		showBoolConf stereo      "stereo",+		showIntConf  camera      "camera",+		showBoolConf textures    "textures",+		showBoolConf reflection  "reflection",+		showBoolConf multisample "multisample",+		showBoolConf mipmap      "mipmap",+		showIntConf  aniso       "aniso",+		showBoolConf background  "background",+		showBoolConf shadow      "shadow",+		showIntConf  audioBuff   "audio_buff",+		showIntConf  mouseSense  "mouse_sense",+		showIntConf  mouseResp   "mouse_response",+		showBoolConf mouseInvert "mouse_invert",+		showBoolConf mouseVsync  "vsync",+		showBoolConf hmd         "hmd",+		showBoolConf highdpi     "highdpi",++		showIntConf  mouseCamera1      "mouse_camera_1",+		showIntConf  mouseCamera2      "mouse_camera_1",+		showIntConf  mouseCameraToggle "mouse_camera_toggle",+		showIntConf  mouseCameraL      "mouse_camera_l",+		showIntConf  mouseCameraR      "mouse_camera_r",++		showIntConf  nice        "nice",+		showIntConf  fps         "fps",+		showIntConf  soundVolume "sound_volume",+		showIntConf  musicVolume "music_volume",++		showBoolConf joystick             "joystick",+		showIntConf  joystickResp         "joystick_response",+		showIntConf  joystickAxisX0       "joystick_axis_x0",+		showIntConf  joystickAxisY0       "joystick_axis_x1",+		showIntConf  joystickAxisX1       "joystick_axis_y0",+		showIntConf  joystickAxisY1       "joystick_axis_y1",+		showBoolConf joystickAxisX0Invert "joystick_axis_x0",+		showBoolConf joystickAxisY0Invert "joystick_axis_x1",+		showBoolConf joystickAxisX1Invert "joystick_axis_y0",+		showBoolConf joystickAxisY1Invert "joystick_axis_y1",++		showIntConf  joystickButtonA      "joystick_button_a",+		showIntConf  joystickButtonB      "joystick_button_b",+		showIntConf  joystickButtonX      "joystick_button_x",+		showIntConf  joystickButtonY      "joystick_button_y",+		showIntConf  joystickButtonL1     "joystick_button_l1",+		showIntConf  joystickButtonL2     "joystick_button_r1",+		showIntConf  joystickButtonR1     "joystick_button_l2",+		showIntConf  joystickButtonR2     "joystick_button_r2",+		showIntConf  joystickButtonSelect "joystick_button_select",+		showIntConf  joystickButtonStart  "joystick_button_start",+		showIntConf  joystickDpadL        "joystick_dpad_l",+		showIntConf  joystickDpadR        "joystick_dpad_r",+		showIntConf  joystickDpadU        "joystick_dpad_u",+		showIntConf  joystickDpadD        "joystick_dpad_d",++		showBoolConf wiimoteInvertPitch  "wiimote_invert_pitch",+		showBoolConf wiimoteInvertRoll   "wiimote_invert_roll",+		showIntConf  wiimotePitchSens    "wiimote_pitch_sensitivity",+		showIntConf  wiimoteRollSense    "wiimote_roll_sensitivity",+		showIntConf  wiimoteSmoothAlpha  "wiimote_smooth_alpha",+		showBoolConf wiimoteHoldSideways "wiimote_hold_sideways",++		showIntConf  keyCamera1      "key_camera_1",+		showIntConf  keyCamera2      "key_camera_2",+		showIntConf  keyCamera3      "key_camera_3",+		showIntConf  keyCameraToggle "key_camera_toggle",+		showIntConf  keyCameraR      "key_camera_r",+		showIntConf  keyCameraL      "key_camera_l",+		showIntConf  keyForward      "key_forward",+		showIntConf  keyBackward     "key_backward",+		showIntConf  keyLeft         "key_left",+		showIntConf  keyRight        "key_right",+		showIntConf  keyRestart      "key_restart",+		showIntConf  keyScoreNext    "key_score_next",+		showIntConf  keyRotateFast   "key_rotate_fast",++		showIntConf  viewFov    "view_fov",+		showIntConf  viewDp     "view_dp",+		showIntConf  viewDc     "view_dc",+		showIntConf  viewDz     "view_dz",+		showIntConf  rotateFast "rotate_fast",+		showIntConf  rotateSlow "rotate_slow",+		showBoolConf cheat      "cheat",+		showBoolConf stats      "stats",+		showBoolConf screenshot "screenshot",+		showBoolConf lockGoals  "lock_goals",++		showIntConf  camera1Speed "camera_1_speed",+		showIntConf  camera2Speed "camera_2_speed",+		showIntConf  camera3Speed "camera_3_speed",++		showIntConf  cameraTouchRotate "touch_rotate",++		showStringConf player      "player",+		showStringConf ballFile    "ball_file",+		showStringConf wiimoteAddr "wiimote_addr",+		showStringConf replayName  "replay_name",+		showStringConf language    "language",+		showStringConf theme       "theme"+	]
+ Immutaball/Share/Context.hs view
@@ -0,0 +1,64 @@+{-# 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 #-}++-- State.hs.++{-# LANGUAGE Haskell2010 #-}+{-# LANGUAGE TemplateHaskell #-}++module Immutaball.Share.Context+	(+		IBContext'(..), ibStaticConfig, ibDirs, ibNeverballrc0, ibInitialWire,+			ibHeadless, ibSDLManagerHandle, ibGLManagerHandle,+		withSDL+	) where++import Prelude ()+import Immutaball.Prelude++import Control.Lens++import Immutaball.Share.Config+import Immutaball.Share.Context.Config+import Immutaball.Share.ImmutaballIO+import Immutaball.Share.GLManager+import Immutaball.Share.SDLManager++-- | An Immutaball context instance.+--+-- The controller has access to this.+data IBContext' initialWire = IBContext {+	_ibStaticConfig :: StaticConfig' (IBContext' initialWire -> Maybe initialWire),+	_ibDirs         :: IBDirs,+	-- | The _initial_ neverballrc.+	_ibNeverballrc0 :: Neverballrc,+	_ibInitialWire  :: IBContext' initialWire -> Maybe initialWire,+	_ibHeadless     :: Bool,++	_ibSDLManagerHandle :: SDLManagerHandle,+	_ibGLManagerHandle :: GLManagerHandle+}+makeLenses ''IBContext'++-- | Just set up SDL.+--+-- Does not create a window or set up OpenGL.+withSDL :: ContextConfig' (IBContext' initialWire) initialWire -> (IBContext' initialWire -> ImmutaballIO) -> ImmutaballIO+withSDL cxtCfg withCxt =+	-- We used to SDL.Init here, but in case initializing in a different thread+	-- causes issue (as was the case for SDL GL swapping), I moved it to the+	-- SDL Manager thread.+	let headless = (cxtCfg^.cxtCfgHeadless) in+	maybe (withSDLManager' headless) (&) (cxtCfg^.cxtCfgUseExistingSDLManager) $ \sdlManagerHandle ->+	maybe (withGLManager)            (&) (cxtCfg^.cxtCfgUseExistingGLManager)  $ \glManagerHandle ->+	withCxt $ IBContext {+		_ibStaticConfig = cxtCfg^.cxtCfgStaticConfig,+		_ibDirs         = cxtCfg^.cxtCfgDirs,+		_ibNeverballrc0 = cxtCfg^.cxtCfgNeverballrc,+		_ibInitialWire  = cxtCfg^.cxtCfgInitialWire,+		_ibHeadless     = cxtCfg^.cxtCfgHeadless,++		_ibSDLManagerHandle = sdlManagerHandle,+		_ibGLManagerHandle  = glManagerHandle+	}
+ Immutaball/Share/Context/Config.hs view
@@ -0,0 +1,46 @@+{-# 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 #-}++-- State.hs.++{-# LANGUAGE Haskell2010 #-}+{-# LANGUAGE TemplateHaskell #-}++module Immutaball.Share.Context.Config+	(+		IBDirs(..), ibStaticDataDir, ibUserDataDir, ibUserConfigDir,+		ContextConfig'(..), cxtCfgStaticConfig, cxtCfgDirs, cxtCfgNeverballrc,+			cxtCfgInitialWire, cxtCfgHeadless, cxtCfgUseExistingSDLManager,+			cxtCfgUseExistingGLManager+	) where++import Prelude ()+import Immutaball.Prelude++import Control.Lens++import Immutaball.Share.Config+import Immutaball.Share.GLManager+import Immutaball.Share.SDLManager++data IBDirs = IBDirs {+	_ibStaticDataDir :: FilePath,+	_ibUserDataDir   :: FilePath,+	_ibUserConfigDir :: FilePath+}+	deriving (Eq, Ord, Show)+makeLenses ''IBDirs++data ContextConfig' cxt initialWire = ContextConfig {+	_cxtCfgStaticConfig :: StaticConfig' (cxt -> Maybe initialWire),+	_cxtCfgDirs         :: IBDirs,+	_cxtCfgNeverballrc  :: Neverballrc,+	_cxtCfgInitialWire  :: cxt -> Maybe initialWire,+	_cxtCfgHeadless     :: Bool,++	-- | Allow tests to share a single manager.+	_cxtCfgUseExistingSDLManager :: Maybe SDLManagerHandle,+	_cxtCfgUseExistingGLManager  :: Maybe GLManagerHandle+}+makeLenses ''ContextConfig'
+ Immutaball/Share/Controller.hs view
@@ -0,0 +1,243 @@+{-# 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 #-}++-- State.hs.++{-# LANGUAGE Haskell2010 #-}++module Immutaball.Share.Controller+	(+		controlImmutaball,+		takeAllSDLEventsIndividually,+		takeAllSDLEventsList,+		takeAllSDLEvents,+		stepFrameNoMaxClockPeriod,+		stepFrame,+		stepEvent,+		stepEventNoMaxClockPeriod,+		stepClock,+		processStepResult,+		doesResponseFork,+		unimplementedHelper,++		-- * SDL utils+		isKbdEventDown,+		kbdEventChar,+		isMousePressed,+		getMouseButton+	) where++import Prelude ()+import Immutaball.Prelude++import Data.Function hiding (id, (.))+import Data.List++import Control.Concurrent.STM.TMVar+import Control.Lens+import SDL.Event+import SDL.Input.Keyboard+import qualified SDL.Raw.Enum as Raw+import SDL.Vect++import Control.Monad.Trans.MaybeM+import Immutaball.Share.AutoPar+import Immutaball.Share.Config+import Immutaball.Share.Context+import Immutaball.Share.ImmutaballIO+import Immutaball.Share.ImmutaballIO.BasicIO+import Immutaball.Share.SDLManager+import Immutaball.Share.State+import Immutaball.Share.Utils+import Immutaball.Share.Wire++controlImmutaball :: IBContext -> Immutaball -> ImmutaballIO+controlImmutaball cxt0 immutaball0 =+	result+	where+		result :: ImmutaballIO+		result = initialFrame+		initialFrame :: ImmutaballIO+		initialFrame =+			mkBIO . GetUs $ \us0 ->+			nextFrame us0 [] immutaball0+		nextFrame :: Integer -> [Event] -> Immutaball -> ImmutaballIO+		nextFrame usNm1 queuedEvents immutaballN =+			mkBIO . GetUs $ \usN ->+			let dus = max 0 $ usN - usNm1 in+			let ds = (fromInteger dus / 1000000.0)  :: Double in+			let usNm1pMinClockPeriod = usNm1 + (max 0 . round $ 1000000.0 * maybe 0 id (cxt0^.ibStaticConfig.minClockPeriod)) in+			if' (usN < usNm1pMinClockPeriod) (mkBIO . DelayUs (usNm1pMinClockPeriod - usN)) id .+			takeAllSDLEvents cxt0 $ \events ->+			let events' = queuedEvents ++ events in+			let events'' = maybe id (take . fromIntegral) (cxt0^.ibStaticConfig.maxFrameEvents) events' in+			stepFrame' cxt0 ds usN events'' immutaballN (nextFrame usN)+		stepFrame'+			| Nothing <- (cxt0^.ibStaticConfig.maxClockPeriod) = stepFrameNoMaxClockPeriod'+			| otherwise                                        = stepFrame+		stepFrameNoMaxClockPeriod' cxt ds us events immutaball withImmutaball =+			stepFrameNoMaxClockPeriod cxt ds us events immutaball (withImmutaball [])++takeAllSDLEventsIndividually :: IBContext -> ([Event] -> ImmutaballIO) -> ImmutaballIO+takeAllSDLEventsIndividually cxt withEvents =+	mkAtomically newEmptyTMVar $ \eventStorage ->+	flip fix [] $ \me events ->+	Fixed . issueSDLCommand (cxt^.ibSDLManagerHandle) (PollEvent eventStorage) .+	mkAtomically (takeTMVar eventStorage) $ \mevent ->+	case mevent of+		Nothing -> withEvents $ reverse events+		Just event -> me (event:events)++takeAllSDLEventsList :: IBContext -> ([Event] -> ImmutaballIO) -> ImmutaballIO+takeAllSDLEventsList cxt withEvents =+	mkAtomically newEmptyTMVar $ \eventsStorage ->+	Fixed . issueSDLCommand (cxt^.ibSDLManagerHandle) (PollEvents eventsStorage) .+	mkAtomically (takeTMVar eventsStorage) $ \events ->+	withEvents events++takeAllSDLEvents :: IBContext -> ([Event] -> ImmutaballIO) -> ImmutaballIO+takeAllSDLEvents = takeAllSDLEventsIndividually++-- | Step each event then clock.+stepFrameNoMaxClockPeriod :: IBContext -> Double -> Integer -> [Event] -> Immutaball -> (Immutaball -> ImmutaballIO) -> ImmutaballIO+stepFrameNoMaxClockPeriod cxt ds us events immutaball withImmutaball =+	foldr+		(\event withImmutaballNp1 -> \immutaballN -> stepEventNoMaxClockPeriod cxt event immutaballN withImmutaballNp1)+		(\immutaballN -> stepClock cxt ds us immutaballN withImmutaball)+		events+		immutaball++-- | Step each event then clock.+--+-- This variant handles 'maxClockPeriod' (see documentation in 'StaticConfig').+-- It ensures that if 'maxClockPeriod' amount of time has passed since any+-- clock step, a clock step is inserted before processing the next event,+-- if at least one event has been processed.+stepFrame :: IBContext -> Double -> Integer -> [Event] -> Immutaball -> ([Event] -> Immutaball -> ImmutaballIO) -> ImmutaballIO+stepFrame cxt ds us events immutaball withImmutaball =+	let z = (\queued _mclockAtUs _noClock immutaballN -> stepClock cxt ds us immutaballN (withImmutaball queued)) in+	let defer = \queued -> z queued Nothing False in+	let eventsWithRemaining = zip events (drop 1 $ tails events) in+	foldr+		(\(event, eventsRemaining) withImmutaballNp1 -> \mclockAtUs noClock immutaballN -> stepEvent cxt event eventsRemaining mclockAtUs noClock immutaballN defer withImmutaballNp1)+		(z [])+		eventsWithRemaining+		((\p -> max 0 . round $ 1000000.0 * p) <$> (cxt^.ibStaticConfig.maxClockPeriod))+		True+		immutaball++-- | Step an event; variant that handles 'maxClockPeriod'.+--+-- maxClockPeriod: the maybe argument just makes it so that if the current time in+-- milliseconds is >= the threshold, we insert a clock step before processing+-- more events.  Then we also use the ‘noClock’ Bool to make sure we process at+-- least one Event at a time.+stepEvent ::+	IBContext -> Event -> [Event] ->+	Maybe Integer -> Bool -> Immutaball ->+	([Event] -> Immutaball -> ImmutaballIO) ->+	(Maybe Integer -> Bool -> Immutaball -> ImmutaballIO) ->+	ImmutaballIO+stepEvent cxt event eventsRemaining mclockAtUs noClock immutaballN defer withImmutaballNp1 =+	case (mclockAtUs, noClock) of+		(Just clockAtUs, False) ->+			mkBIO . GetUs $ \us_ ->+			if' (not $ us_ >= clockAtUs)+				(+					stepEventNoMaxClockPeriod cxt event immutaballN (withImmutaballNp1 mclockAtUs False)+				)+				(+					defer eventsRemaining immutaballN+				)+		_ -> stepEventNoMaxClockPeriod cxt event immutaballN (withImmutaballNp1 mclockAtUs noClock)++-- | Step an event.+stepEventNoMaxClockPeriod :: IBContext -> Event -> Immutaball -> (Immutaball -> ImmutaballIO) -> ImmutaballIO+stepEventNoMaxClockPeriod cxt event immutaballN withImmutaballNp1 =+	case event of+		(Event _ (QuitEvent)) ->+			mempty+		(Event _ (MouseMotionEvent (MouseMotionEventData _ _ _ (P (V2 x y)) (V2 dx dy)))) ->+			let (x', y', dx', dy') = (fromIntegral x, fromIntegral y, fromIntegral dx, fromIntegral dy) in+			let mresponse = stepWire immutaballN (pure $ Point x' y' dx' dy') in+			processStepResult cxt mresponse withImmutaballNp1+		(Event _ (MouseButtonEvent (MouseButtonEventData _ pressed _ mouseButton _ _))) ->+			let (button, down) = (fromIntegral $ getMouseButton mouseButton, isMousePressed pressed) in+			let mresponse = stepWire immutaballN (pure $ Click button down) in+			processStepResult cxt mresponse withImmutaballNp1+		(Event _ (KeyboardEvent kbdEvent)) ->+			let (char, down) = (fromIntegral $ kbdEventChar kbdEvent, isKbdEventDown kbdEvent) in+			let mresponse = stepWire immutaballN (pure $ Keybd char down) in+			processStepResult cxt mresponse withImmutaballNp1+		_ ->+			-- Ignore all unhandled events.+			withImmutaballNp1 immutaballN++stepClock :: IBContext -> Double -> Integer -> Immutaball -> (Immutaball -> ImmutaballIO) -> ImmutaballIO+stepClock cxt ds us immutaballN withImmutaballNp1 =+	let mresponse = stepWire immutaballN (pure $ Clock ds) in+	processStepResult cxt mresponse $ \immutaballNp1 ->+	let mresponse_ = stepWire immutaballNp1 (pure . Paint $ (fromIntegral us) / 1000000.0) in+	if' (cxt^.ibHeadless)+		(withImmutaballNp1 immutaballNp1)+		(processStepResult cxt mresponse_ withImmutaballNp1)++processStepResult :: (Foldable t) => IBContext -> ImmutaballM (t Response, Immutaball) -> (Immutaball -> ImmutaballIO) -> ImmutaballIO+processStepResult cxt mresponse withImmutaballNp1 =+	runAutoParT mresponse & \mioresponse ->+	either (\ioresponse -> Fixed . flip fmap ioresponse) (&) (runMaybeMT mioresponse) $ \(response, immutaballNp1) ->+	let failFork = mkBIO . PutStrLn "Error: processStepResult: wire forking is disabled, but the wire requested a fork; aborting" $ mkBIO ExitFailureBasicIOF in+	if' (not (cxt^.ibStaticConfig.allowWireForks) && doesResponseFork response) failFork $+	flip foldMap response $ \responseI ->+	case responseI of+		ContinueResponse -> withImmutaballNp1 immutaballNp1+		DoneResponse -> mempty+		PureFork immutaballFork -> withImmutaballNp1 immutaballFork <> withImmutaballNp1 immutaballNp1+		ImmutaballIOFork mimmutaballFork -> Fixed (fmap withImmutaballNp1 mimmutaballFork) <> withImmutaballNp1 immutaballNp1++doesResponseFork :: (Foldable t) => t Response -> Bool+doesResponseFork response+	| any isFork responses = True+	| lcontinues > 1       = True+	| otherwise            = False+	where+		responses :: [Response]+		responses = foldr (:) [] response+		isFork :: Response -> Bool+		isFork (ContinueResponse  ) = False+		isFork (DoneResponse      ) = False+		isFork (PureFork         _) = True+		isFork (ImmutaballIOFork _) = True+		isContinue :: Response -> Bool+		isContinue (ContinueResponse  ) = True+		isContinue (DoneResponse      ) = False+		isContinue (PureFork         _) = False+		isContinue (ImmutaballIOFork _) = False+		lcontinues :: Integer+		lcontinues = genericLength . filter isContinue $ responses++unimplementedHelper :: ImmutaballIO+unimplementedHelper =+	runBasicImmutaballIO (mkPutStrLn "Internal error: unimplemented." $ mkExitFailureBasicIO)++-- * SDL utils++isKbdEventDown :: KeyboardEventData -> Bool+isKbdEventDown (KeyboardEventData _ Pressed  _ _) = True+isKbdEventDown (KeyboardEventData _ Released _ _) = False++kbdEventChar :: KeyboardEventData -> Integer+kbdEventChar (KeyboardEventData _ _ _ (Keysym _ (Keycode keyCode) _)) = (fromIntegral keyCode)++isMousePressed :: InputMotion -> Bool+isMousePressed Pressed  = True+isMousePressed Released = False++getMouseButton :: MouseButton -> Integer+getMouseButton (ButtonLeft)         = Raw.SDL_BUTTON_LEFT+getMouseButton (ButtonMiddle)       = Raw.SDL_BUTTON_MIDDLE+getMouseButton (ButtonRight)        = Raw.SDL_BUTTON_RIGHT+getMouseButton (ButtonX1)           = Raw.SDL_BUTTON_X1+getMouseButton (ButtonX2)           = Raw.SDL_BUTTON_X2+getMouseButton (ButtonExtra button) = fromIntegral button
+ Immutaball/Share/GLManager.hs view
@@ -0,0 +1,118 @@+{-# 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 #-}++-- State.hs.++{-# LANGUAGE Haskell2010 #-}++-- | A thread that can order GL commands in sequence.+--+-- When GL commands need to be in order to be correct, this thread can be+-- useful for this end.+--+-- Having a GL thread issuing OpenGL separate from the SDL manager thread+-- seemed to have issues on my platform, so I switched to having the SDL+-- manager thread execute GL commands.  I might remove this module in the+-- future.+module Immutaball.Share.GLManager+	(+		-- * High level+		withGLManager,+		GLManagerHandle(..), glmh_done, glmh_doneReceived, glmh_commands,+		GLManagerCommand(..),+		issueGLCommand,+		glQueueValueless,++		-- * Low level+		initGLManager,+		glForkIBIO,+		quitGLManager,+		glManagerThread+	) where++import Prelude ()+import Immutaball.Prelude++import Control.Concurrent.STM.TVar+import Control.Concurrent.STM.TChan+import Control.Lens+import Control.Monad.STM+import Data.Functor++import Immutaball.Share.ImmutaballIO+import Immutaball.Share.ImmutaballIO.BasicIO+import Immutaball.Share.ImmutaballIO.GLIO+import Immutaball.Share.GLManager.Types++-- * High level++withGLManager :: (GLManagerHandle -> ImmutaballIO) -> ImmutaballIO+withGLManager withHandle =+	initGLManager $ \glManagerHandle ->+	withHandle glManagerHandle <>>+	quitGLManager glManagerHandle++-- Moved to .Types to fix Template Haskell erors:+-- GLManagerHandle+-- GLManagerCommand++issueGLCommand :: GLManagerHandle -> GLManagerCommand -> me -> ImmutaballIOF me+issueGLCommand glMgr cmd withUnit = Atomically (writeTChan (glMgr^.glmh_commands) cmd) (\() -> withUnit)++glQueueValueless :: GLManagerHandle -> [GLIOF ()] -> me -> ImmutaballIOF me+glQueueValueless glMgr orderedGLCommands withUnit =+	issueGLCommand glMgr (GLQueueValueless orderedGLCommands) withUnit++-- * Low level++-- | Manually start the lifetime of the GLManager OS thread; the caller will+-- need to manage the lifetime.+initGLManager :: (GLManagerHandle -> ImmutaballIO) -> ImmutaballIO+initGLManager withGLMgr =+	mkAtomically (newTVar False) $ \done ->+	mkAtomically (newTVar False) $ \doneReceived ->+	mkAtomically newTChan $ \commands ->+	let glMgr = GLManagerHandle {+		_glmh_done         = done,+		_glmh_doneReceived = doneReceived,+		_glmh_commands     = commands+	}+	in glForkIBIO (glManagerThread glMgr) $ withGLMgr glMgr++-- | glForkIBIO: The return value is better associated with the callback rather than the thread, so flip.+glForkIBIO :: ImmutaballIO -> ImmutaballIO -> ImmutaballIO+glForkIBIO = flip mkAndIBIO++-- | Manually close the GLManager thread low-level.  High-level+-- 'withGLManager' automatically manages the lifetime.+quitGLManager :: GLManagerHandle -> ImmutaballIO+quitGLManager glMgr =+	mkAtomically (do+		writeTVar (glMgr^.glmh_done) True) (const mempty) <>+	mkAtomically (do+		writeTChan (glMgr^.glmh_commands) QuitGLManager) (const mempty) <>>+	mkAtomically (do+		readTVar (glMgr^.glmh_doneReceived) >>= check) (const mempty)++glManagerThread :: GLManagerHandle -> ImmutaballIO+glManagerThread glMgr =+	mkAtomically (+		readTVar (glMgr^.glmh_done) >>= \done ->+		(check done $> Left done) `orElse` (Right <$> readTChan (glMgr^.glmh_commands))+	) $ \doneOrCmd ->+	case doneOrCmd of+		Left done -> if not done then glManagerThread glMgr else quit+		Right cmd -> case cmd of+			QuitGLManager -> quit+			NopGLManager -> glManagerThread glMgr+			GLQueueValueless orderedGLCommands -> runOrderedGLValueless orderedGLCommands (glManagerThread glMgr)+	where+		quit :: ImmutaballIO+		quit = mkAtomically (writeTVar (glMgr^.glmh_doneReceived) True) mempty <>> mkAtomically (writeTVar (glMgr^.glmh_done) True) mempty <>> mempty++runOrderedGLValueless :: [GLIOF ()] -> ImmutaballIO -> ImmutaballIO+runOrderedGLValueless orderedGLCommands withUnit =+	case orderedGLCommands of+		[] -> withUnit+		(orderedGLCommand:then_) -> mkBIO . GLIO $ runOrderedGLValueless then_ withUnit <$ orderedGLCommand
+ Immutaball/Share/GLManager/Config.hs view
@@ -0,0 +1,28 @@+{-# 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 #-}++-- State.hs.++{-# LANGUAGE Haskell2010 #-}+{-# LANGUAGE TemplateHaskell #-}++module Immutaball.Share.GLManager.Config+	(+		GLManagerStaticConfig(..),+		defaultGLManagerStaticConfig+	) where++import Prelude ()+--import Immutaball.Prelude++import Control.Lens++data GLManagerStaticConfig = GLManagerStaticConfig {+}+makeLenses ''GLManagerStaticConfig++-- | Default static config.+defaultGLManagerStaticConfig :: GLManagerStaticConfig+defaultGLManagerStaticConfig = GLManagerStaticConfig {+}
+ Immutaball/Share/GLManager/Types.hs view
@@ -0,0 +1,47 @@+{-# 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 #-}++-- State.hs.++{-# LANGUAGE Haskell2010 #-}+{-# LANGUAGE TemplateHaskell #-}++-- | Moved into another module to avoid Template Haskell errors.+module Immutaball.Share.GLManager.Types+	(+		GLManagerHandle(..), glmh_done, glmh_doneReceived, glmh_commands,+		GLManagerCommand(..),+	) where++import Prelude ()+import Immutaball.Prelude++import Control.Concurrent.STM.TVar+import Control.Concurrent.STM.TChan+import Control.Lens++import Immutaball.Share.ImmutaballIO.GLIO++-- Moved from later to fix Template Haskell errors.+data GLManagerCommand =+	-- | Close the manager; it's done.+	  QuitGLManager+	| NopGLManager+	-- | Running e.g. glBindTexture and then glTexImage2D concurrently can+	-- introduces race conditions without ordering management.  Ordered+	-- queueing can help with this.+	-- Note: individual valueless queue commands are not required to run in+	-- parallel.+	| GLQueueValueless [GLIOF ()]+	-- TODO: support general GLIOs like SDLManager does.  If I'm not using this+	-- right now because of SDL limitations, I might not bother at the moment.++-- | The inner fields and lenses are internal (low-level).+data GLManagerHandle = GLManagerHandle {+	_glmh_done :: TVar Bool,+	_glmh_doneReceived :: TVar Bool,+	_glmh_commands :: TChan GLManagerCommand+}+	deriving (Eq)+makeLenses ''GLManagerHandle  -- Error for future module reference.
+ Immutaball/Share/GUI.hs view
@@ -0,0 +1,660 @@+{-# 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 #-}++-- State.hs.++{-# LANGUAGE Haskell2010 #-}+{-# LANGUAGE TemplateHaskell, Arrows, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, ExplicitForAll, InstanceSigs, ScopedTypeVariables, FlexibleContexts, RankNTypes #-}++module Immutaball.Share.GUI+	(+		-- * widgets+		HasWid(..),+		HasWparent(..),+		HasFill(..),+		HasText(..),+		HasRect(..),+		Root(..), rootWid,+		Space(..), spaceWid, spaceWparent, spaceFill,+		Vstack(..), vstackWid, vstackWparent,+		Hstack(..), hstackWid, hstackWparent,+		Label(..), labelWid, labelWparent, labelText, labelRect,+		Button(..), buttonWid, buttonWparent, buttonText, buttonRect,+		Widget(..), AsWidget(..),++		-- * wires+		SetTextOptions,+		SetTextOptionsBuilder,+		SetTextOptions'(..), stoHoldCache,+		defaultSetTextOptions,+		buildSetTextOptions,+		defaultSetTextOptionsBuilder,+		WidgetRequest(..), AsWidgetRequest(..),+		WidgetResponse(..), AsWidgetResponse(..),+		mkGUI,+		mkWidgetsAnalysis,+		mkWidgetBy,+		mkWidgetIdx,+		mkWidgetToIdx,+		mkGetChildren,+		mkGeometry,+		nextWidgetDirect,+		prevWidgetDirect,+		nextWidgetHier,+		prevWidgetHier,+		isSelectable,+		guiPaint,+		guiPaintWidgetsChunk,+		guiPaintWidgets,+		focusDecayTime,+		focusScale,+		focusWaveAmplitude+	) where++import Prelude ()+import Immutaball.Prelude++import Control.Applicative+import Control.Arrow+--import Data.Functor.Identity+import Control.Monad+import Control.Monad.ST+import Data.Function hiding (id, (.))+import Data.List+import Data.Maybe+import Foreign.Storable (sizeOf, Storable)++import Control.Lens+--import Data.Array+import Data.Array.Base+--import Data.Array.MArray+import Data.Array.ST+import Data.Array.Storable+import qualified Data.Map.Lazy as M+import qualified Data.Text as T+import Graphics.GL.Compatibility45+--import Graphics.GL.Core45+import Graphics.GL.Types+import qualified SDL.Raw.Enum as Raw++import Immutaball.Share.Config+import Immutaball.Share.Context+import Immutaball.Share.ImmutaballIO+import Immutaball.Share.ImmutaballIO.BasicIO+import Immutaball.Share.ImmutaballIO.GLIO+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++-- * widgets++data Root id = Root {+	_rootWid :: id+}+	deriving (Eq, Ord, Show)+makeLenses ''Root+makeFields ''Root++data Space id = Space {+	_spaceWid     :: id,+	_spaceWparent :: id,++	-- | Max space to anchor at bottom.+	_spaceFill    :: Bool+}+	deriving (Eq, Ord, Show)+makeLenses ''Space+makeFields ''Space++instance HasWparent (Root id) id where wparent = wid++data Vstack id = Vstack {+	_vstackWid     :: id,+	_vstackWparent :: id+}+	deriving (Eq, Ord, Show)+makeLenses ''Vstack+makeFields ''Vstack++data Hstack id = Hstack {+	_hstackWid     :: id,+	_hstackWparent :: id+}+	deriving (Eq, Ord, Show)+makeLenses ''Hstack+makeFields ''Hstack++data Label id = Label {+	_labelWid     :: id,+	_labelWparent :: id,++	_labelText    :: String,+	_labelRect    :: Maybe (Rect Double)+}+	deriving (Eq, Ord, Show)+makeLenses ''Label+makeFields ''Label++data Button id = Button {+	_buttonWid     :: id,+	_buttonWparent :: id,++	_buttonText    :: String,+	_buttonRect    :: Maybe (Rect Double)+}+	deriving (Eq, Ord, Show)+makeLenses ''Button+makeFields ''Button++data Widget id =+	  RootWidget   (Root   id)+	| SpaceWidget  (Space  id)+	| VstackWidget (Vstack id)+	| HstackWidget (Hstack id)+	| LabelWidget  (Label  id)+	| ButtonWidget (Button id)+	deriving (Eq, Ord, Show)+makeClassyPrisms ''Widget++instance HasWid (Widget id) id where+	wid :: forall f. Functor f => (id -> f id) -> Widget id -> f (Widget id)+	wid accessor (RootWidget   root)   = RootWidget   <$> wid accessor root+	wid accessor (SpaceWidget  space)  = SpaceWidget  <$> wid accessor space+	wid accessor (VstackWidget vstack) = VstackWidget <$> wid accessor vstack+	wid accessor (HstackWidget hstack) = HstackWidget <$> wid accessor hstack+	wid accessor (LabelWidget  label)  = LabelWidget  <$> wid accessor label+	wid accessor (ButtonWidget button) = ButtonWidget <$> wid accessor button+instance HasWparent (Widget id) id where+	wparent :: forall f. Functor f => (id -> f id) -> Widget id -> f (Widget id)+	wparent accessor (RootWidget   root)   = RootWidget   <$> wparent accessor root+	wparent accessor (SpaceWidget  space)  = SpaceWidget  <$> wparent accessor space+	wparent accessor (VstackWidget vstack) = VstackWidget <$> wparent accessor vstack+	wparent accessor (HstackWidget hstack) = HstackWidget <$> wparent accessor hstack+	wparent accessor (LabelWidget  label)  = LabelWidget  <$> wparent accessor label+	wparent accessor (ButtonWidget button) = ButtonWidget <$> wparent accessor button++-- * wires++type SetTextOptions = SetTextOptions' Identity+type SetTextOptionsBuilder = SetTextOptions' Maybe+data SetTextOptions' f = SetTextOptions {+	-- | Request the cache of the old text is not cleared.+	_stoHoldCache :: f Bool+}+	--deriving (Eq, Ord, Show)+makeLenses ''SetTextOptions'++defaultSetTextOptions :: SetTextOptions+defaultSetTextOptions = SetTextOptions {+	_stoHoldCache = Identity False+}++buildSetTextOptions :: SetTextOptionsBuilder -> SetTextOptions+buildSetTextOptions sto = SetTextOptions {+	_stoHoldCache = orDef stoHoldCache defaultSetTextOptions sto+}+	where+		orDef :: (forall f. Lens' (SetTextOptions' f) (f a)) -> SetTextOptions -> SetTextOptionsBuilder -> Identity a+		orDef l def opt = fromMaybe (def^.l) $ Identity <$> (opt^.l)++instance Semigroup SetTextOptionsBuilder where+	a <> b = SetTextOptions {+		_stoHoldCache = (a^.stoHoldCache) <|> (b^.stoHoldCache)+	}+instance Monoid SetTextOptionsBuilder where+	mempty = defaultSetTextOptionsBuilder++defaultSetTextOptionsBuilder :: SetTextOptionsBuilder+defaultSetTextOptionsBuilder = SetTextOptions {+	_stoHoldCache = Nothing+}++data WidgetRequest id =+	  GUIDrive Request+	| GUISetText id String SetTextOptions+	| GUISetFocus id+	| ResetGUI [Widget id]+	--deriving (Eq, Ord, Show)+makeClassyPrisms ''WidgetRequest++data WidgetResponse id =+	  NoWidgetAction+	| WidgetAction id+	deriving (Eq, Ord, Show)+makeClassyPrisms ''WidgetResponse++mkGUI :: forall id. (Eq id, Ord id) => [Widget id] -> Wire ImmutaballM (WidgetRequest id, IBStateContext) (WidgetResponse id, IBStateContext)+mkGUI initialWidgets = proc (request, cxtn) -> do+	-- Set up widgets.+	rec+		directResetWidgets <- returnA -< const Nothing ||| Just $ matching _ResetGUI request+		msetText <- returnA -< const Nothing ||| Just $ matching _GUISetText request++		lastWidgets <- delay initialWidgets -< widgets+		let setTextResetWidgets' = flip fmap msetText $ \(setTextId, setTextText, sto) ->+			-- (This is just a simple map, but the form can be a useful pattern for more complicated processing.)+			-- (Also, for more advanced GUIs with lots af widgets, it would+			-- likely be useful to have a separate map overlay layer of override+			-- texts or other more efficient and better performing structures than+			-- a direct list we reconstruct in its entirety on text update, but+			-- our GUIs are probably simple enough that is probably good enough+			-- for us.)+			let+				setText (LabelWidget  w)  val = LabelWidget  $ w & (text .~ val)+				setText (ButtonWidget w)  val = ButtonWidget $ w & (text .~ val)+				setText w                _val = w+				getText (LabelWidget  w)      = w^.text+				getText (ButtonWidget w)      = w^.text+				getText _w                    = "" in+			(\f -> f lastWidgets []) . fix $ \process remaining oldTexts_ -> case remaining of+				[]     -> ([], oldTexts_)+				(w:ws) ->+					let (w', oldTexts') = if' ((w^.wid) /= setTextId) (w, oldTexts_) $+						(setText w setTextText, if' (not . runIdentity $ sto^.stoHoldCache) oldTexts_ $ getText w : oldTexts_) in+					--w' : process ws+					first (w' :) $ process ws oldTexts'+		let setTextResetWidgets = fmap fst setTextResetWidgets'+		let oldTexts = fromMaybe [] $ fmap snd setTextResetWidgets'+		let resetWidgets = directResetWidgets <|> setTextResetWidgets+		widgets <- hold initialWidgets -< resetWidgets++	-- On direct reset, clear the text cache; we're the only user.+	cxtnp1 <- returnA ||| clearTextCache -< const cxtn +++ const cxtn $ matching _ResetGUI request+	-- On the first step, clear the text cache; we're the only user.+	isFirst <- delay True -< returnA False+	cxtnp2 <- returnA ||| clearTextCache -< if' (not isFirst) Left Right cxtnp1++	-- On clearing old texts, remove the old text.  (We could hold onto an+	-- S.Set of currently active texts, but if there's still another text texture+	-- referring to it, it'll simply be regenerated, so it's a small cost we can+	-- handle.)+	cxtnp3 <- foldrA uncacheText -< (cxtnp2, T.pack <$> oldTexts)++	-- Analyze widgets.+	widgetsReq  <- returnA -< resetWidgets+	widgetBy    <- mkWidgetsAnalysis' mkWidgetBy    -< widgetsReq+	widgetIdx   <- mkWidgetsAnalysis' mkWidgetIdx   -< widgetsReq+	widgetToIdx <- mkWidgetsAnalysis' mkWidgetToIdx -< widgetsReq+	getChildren <- mkWidgetsAnalysis' mkGetChildren -< widgetsReq+	geometry    <- mkWidgetsAnalysis' mkGeometry    -< widgetsReq++	nextWidgetHier' <- returnA -< nextWidgetHier widgetBy getChildren+	prevWidgetHier' <- returnA -< prevWidgetHier widgetBy getChildren++	-- Handle mouse movement.+	--mousePos <- hold ((-1.1), (1.1)) -< (const Nothing) ||| matching _Point $ matching _GUIDrive request+	let+		convertPoint :: (Integral i) => IBStateContext -> (i, i, i, i) -> Vec2 Double+		convertPoint cxt_ (x, y, _dx, _dy) =+			Vec2+				( lerp (-1.0) (1.0) (     ilerp (0.0 :: Double) (fromIntegral (cxt_^.ibNeverballrc.width ) :: Double) (fromIntegral x)) )+				( lerp (-1.0) (1.0) (flip ilerp (0.0 :: Double) (fromIntegral (cxt_^.ibNeverballrc.height) :: Double) (fromIntegral y)) )+	let newMousePos = (const Nothing ||| Just . convertPoint cxtnp3) . matching (_GUIDrive . _Point) $ request+	(_mousePos, mouseFocus) <- hold (Vec2 (-1.1) (1.1), Nothing) -< flip fmap newMousePos $ \pos ->+		let widgetsUnderMouse = M.keys . M.filterWithKey (\wid_ r -> ((isSelectable <$> flip M.lookup widgetBy wid_) == Just True) && isInRect r pos) $ geometry in+		let mwidgetUnderMouse = safeHead widgetsUnderMouse in+		(pos, mwidgetUnderMouse >>= flip M.lookup widgetBy >>= flip M.lookup widgetToIdx)++	-- Manage focus.+	rec+		initialFocus <- returnA -< maybe 0 id $ flip M.lookup widgetIdx 0 >>= flip M.lookup widgetBy . nextWidgetHier' . prevWidgetHier' . (^.wid) >>= flip M.lookup widgetToIdx+		currentFocus <- holdWith -< (newFocus, initialFocus)+		lastFocus <- delayWith -< (currentFocus, initialFocus)+		newFocus0 <- case request of+			GUISetFocus wid_ -> returnA -< flip M.lookup widgetBy wid_ >>= flip M.lookup widgetToIdx+			GUIDrive (Keybd char True) -> returnA -<+				if' (char == fromIntegral Raw.SDLK_DOWN) (Just $ nextWidgetDirect widgetIdx lastFocus) .+				if' (char == fromIntegral Raw.SDLK_UP  ) (Just $ prevWidgetDirect widgetIdx lastFocus) $+				Nothing+			_ -> returnA -< Nothing+		newFocus <- returnA -< newFocus0 <|> (join (mouseFocus <$ newMousePos) >>= \mouseFocus_ -> if' (mouseFocus_ == lastFocus) Nothing $ Just mouseFocus_)++		-- Find 'widgetsFocusedSinceLastPaintIdx'.+		isPaint <- returnA -< case request of (GUIDrive (Paint _t)) -> True; _ -> False+		lastIsPaint <- delay False -< isPaint+		lastWidgetsFocusedSinceLastPaintIdx <- delay [] -< widgetsFocusedSinceLastPaintIdx+		(widgetsFocusedSinceLastPaintIdx :: [Integer]) <- returnA -<+			catMaybes [newFocus] ++ if' lastIsPaint [] lastWidgetsFocusedSinceLastPaintIdx+		(widgetsFocusedSinceLastPaint :: [id]) <- returnA -<+			flip mapMaybe widgetsFocusedSinceLastPaintIdx $ \idx -> (^.wid) <$> flip M.lookup widgetIdx idx++	-- Paint.+	currentFocusWid <- returnA -< fromMaybe (error "Internal error: mkGUI: currentFocus not in widgetIdx.") $ (^.wid) <$> flip M.lookup widgetIdx currentFocus+	cxtnp4 <- case request of+		GUIDrive (Paint t) -> guiPaint -< (widgets, geometry, widgetBy, widgetsFocusedSinceLastPaint, currentFocusWid, t, cxtnp3)+		_ -> returnA -< cxtnp3++	-- Set up response.+	let responseOnAction = (maybe NoWidgetAction id $ WidgetAction . (^.wid) <$> flip M.lookup widgetIdx currentFocus)+	response <- returnA -< case request of+		GUIDrive (Keybd char True) ->+			if' (char == fromIntegral Raw.SDLK_RETURN) responseOnAction $+			NoWidgetAction+		GUIDrive (Click Raw.SDL_BUTTON_LEFT True) ->+			if' (mouseFocus == Just currentFocus) responseOnAction $+			NoWidgetAction+		_ -> NoWidgetAction+	returnA -< (response, cxtnp4)+	where+		mkWidgetsAnalysis' = mkWidgetsAnalysis initialWidgets+		_warn :: String -> Wire ImmutaballM () ()+		_warn msg = proc () -> do+			() <- monadic -< liftIBIO . BasicIBIOF $ PutStrLn msg ()+			returnA -< ()++-- | Only recalculates the analysis on reset.+mkWidgetsAnalysis :: [Widget id] -> ([Widget id] -> a) -> Wire ImmutaballM (Maybe [Widget id]) a+mkWidgetsAnalysis initialWidgets analyzer = proc resetWidgets -> do+	hold (analyzer initialWidgets) -< analyzer <$> resetWidgets++mkWidgetBy :: (Eq id, Ord id) => [Widget id] -> M.Map id (Widget id)+mkWidgetBy widgets = M.fromList . flip map widgets $ \w -> ((w^.wid), w)++mkWidgetIdx :: [Widget id] -> M.Map Integer (Widget id)+mkWidgetIdx widgets = M.fromList $ zip [0..] widgets++mkWidgetToIdx :: (Eq id, Ord id) => [Widget id] -> M.Map (Widget id) Integer+mkWidgetToIdx widgets = M.fromList $ zip widgets [0..]++mkGetChildren :: (Eq id) => [Widget id] -> id -> [Widget id]+mkGetChildren widgets parent = filter (\w -> (w^.wparent) == parent) widgets++-- TODO: make a more sophisticated geometry.+-- For now I'll just specify the rect by hand.+mkGeometry :: forall id. (Eq id, Ord id) => [Widget id] -> M.Map id (Rect Double)+--mkGeometry widgets = M.fromList . flip mapMaybe widgets . (\(a,b)->(a,)<$>b) . (id &&&) $ \w -> case w of+mkGeometry widgets = M.fromList . map (first (^.wid)) . flip mapMaybe widgets . (uncurry fmap .) . ((,) &&&) $ \w -> case w of+	(LabelWidget label) -> label^.labelRect+	(ButtonWidget button) -> button^.buttonRect+	_ -> Nothing++-- | The order is the order reflected in the input widgets.+nextWidgetDirect :: (Eq id, Ord id) => M.Map Integer (Widget id) -> Integer -> Integer+nextWidgetDirect widgetIdx idx = tryNextWidget (idx+1)+	where tryNextWidget idx_+		| idx_ == idx = idx_+		| idx_ >= (fromIntegral $ M.size widgetIdx) = tryNextWidget 0+		| maybe False isSelectable $ M.lookup idx_ widgetIdx = idx_+		| otherwise = tryNextWidget (idx_+1)+prevWidgetDirect :: (Eq id, Ord id) => M.Map Integer (Widget id) -> Integer -> Integer+prevWidgetDirect widgetIdx idx = tryNextWidget (idx-1)+	where tryNextWidget idx_+		| idx_ == idx = idx_+		| idx_ < 0 = tryNextWidget ((fromIntegral $ M.size widgetIdx)-1)+		| maybe False isSelectable $ M.lookup idx_ widgetIdx = idx_+		| otherwise = tryNextWidget (idx_-1)++-- | The order is input order except container hierarchy takes precedence.+-- Does not check for cycles.+nextWidgetHier :: (Eq id, Ord id) => M.Map id (Widget id) -> (id -> [Widget id]) -> id -> id+nextWidgetHier widgetBy getChildren wid0 = maybe wid0 (nextWidgetUnder True wid0 . (^.wparent)) $ M.lookup wid0 widgetBy+	where+		wBy = flip M.lookup widgetBy+		nextWidgetUnder isFirst wid_ parent+			| not isFirst && wid_ == wid0 = wid0+			| wid_ == parent = withRemaining . filter (\w -> (w^.wid) /= wid_) $ getChildren parent+			| otherwise = withRemaining . drop 1 . dropWhile (\w -> (w^.wid) /= wid_) $ getChildren parent+			where+				withRemaining []                                 = maybe wid0 (\parent_ -> nextWidgetUnder False (parent_^.wid) (parent_^.wparent)) $ wBy parent+				withRemaining ( w:_remaining) | (w^.wid) == wid0 = w^.wid+				withRemaining ( w:_remaining) | isSelectable w   = w^.wid+				withRemaining (_w: remaining) | otherwise        = withRemaining remaining+prevWidgetHier :: (Eq id, Ord id) => M.Map id (Widget id) -> (id -> [Widget id]) -> id -> id+prevWidgetHier widgetBy getChildren wid0 = maybe wid0 (prevWidgetUnder True wid0 . (^.wparent)) $ M.lookup wid0 widgetBy+	where+		wBy = flip M.lookup widgetBy+		prevWidgetUnder isFirst wid_ parent+			| not isFirst && wid_ == wid0 = wid0+			| wid_ == parent = withRemaining . filter (\w -> (w^.wid) /= wid_) . reverse $ getChildren parent+			| otherwise = withRemaining . drop 1 . dropWhile (\w -> (w^.wid) /= wid_) . reverse $ getChildren parent+			where+				withRemaining []                                 = maybe wid0 (\parent_ -> prevWidgetUnder False (parent_^.wid) (parent_^.wparent)) $ wBy parent+				withRemaining ( w:_remaining) | (w^.wid) == wid0 = w^.wid+				withRemaining ( w:_remaining) | isSelectable w   = w^.wid+				withRemaining (_w: remaining) | otherwise        = withRemaining remaining++isSelectable :: Widget id -> Bool+isSelectable (ButtonWidget {}) = True+isSelectable _                 = False++guiPaint :: forall id. (Eq id, Ord id) => Wire ImmutaballM ([Widget id], M.Map id (Rect Double), M.Map id (Widget id), [id], id, Double, IBStateContext) IBStateContext+guiPaint = proc (widgets, geometry, widgetBy, widgetsFocusedSinceLastPaint, currentFocusWid, t, cxtn) -> do+	rec+		(widgetLastFocusLast :: M.Map id Double) <- delay M.empty -< widgetLastFocus+		widgetLastFocus <- returnA -< M.filter (> t - focusDecayTime) $ foldr (\wid_ -> M.insert wid_ t) widgetLastFocusLast widgetsFocusedSinceLastPaint++	chunks' <- returnA -< chunksOf (cxtn^.ibContext.ibStaticConfig.x'cfgMaxPassTextures)+	cxtnp1 <- foldrA guiPaintWidgetsChunk -< (cxtn, flip map (chunks' widgets) $ \ws -> (ws, widgetLastFocus, geometry, widgetBy, currentFocusWid, t))+	returnA -< cxtnp1++guiCachingRenderText :: forall id. (Eq id, Ord id) => Wire ImmutaballM (Widget id, IBStateContext) (Maybe (WidthHeightI, GLuint), IBStateContext)+guiCachingRenderText = proc (widget, cxtn) -> do+	let mtext' = case widget of+		(ButtonWidget button) -> Just (button^.text)+		(LabelWidget  label)  -> Just (label^.text)+		_                     -> Nothing+	let mtext | mtext' == Just "" = Nothing | otherwise = mtext'  -- sdl2-ttf fails on an nempty string (zero width error).+	(mdimName, cxtnp1) <- returnA ||| (first Just) <$> cachingRenderText -< maybe (Left (Nothing, cxtn)) (\text_ -> Right (T.pack $ text_, cxtn)) $ mtext+	returnA -< (mdimName, cxtnp1)++-- | Just process 16 at a time, the number of textures our shader can handle at a time.+guiPaintWidgetsChunk :: forall id. (Eq id, Ord id) => Wire ImmutaballM (([Widget id], M.Map id Double, M.Map id (Rect Double), M.Map id (Widget id), id, Double), IBStateContext) IBStateContext+guiPaintWidgetsChunk = proc ((widgets, widgetLastFocus, geometry, widgetBy, currentFocusWid, t), cxtn) -> do+	-- let guiCacheRenderText' = guiCacheRenderText that accumulates on its left input.+	--guiCacheRenderText' <- returnA -< guiCacheRenderText …+	(mdimNames :: [Maybe (WidthHeightI, GLuint)], cxtnp1) <- foldrA guiCacheRenderText' -< (([], cxtn), widgets)+	let (mRects :: [Maybe (Rect Double)]) = flip map widgets $ \w -> M.lookup (w^.wid) geometry+	let (wids :: [Maybe id]) = flip map widgets $ \w -> Just (w^.wid)+	--let paintWidgets = catMaybes $ zipWith (liftA2 (,)) mdimNames mRects+	let paintWidgets = catMaybes . zipWith (liftA2 (,)) wids $ zipWith (liftA2 (,)) mdimNames mRects+	cxtnp2 <- guiPaintWidgets -< (paintWidgets, widgetLastFocus, widgetBy, currentFocusWid, t, cxtnp1)+	returnA -< cxtnp2+	where+		-- let guiCacheRenderText' = guiCacheRenderText that accumulates on its left input.+		guiCacheRenderText' = proc (w, (mdimNames, icxtn)) -> do+			(mdimName, icxtnp1) <- guiCachingRenderText -< (w, icxtn)+			returnA -< (mdimName : mdimNames, icxtnp1)++-- | OpenGL paint the GUI widgets.+--+-- BUild vertex data to upload to the GPU, set the texture name+-- shader-variables (aka uniforms), and then issue the GL draw commands.  The+-- higher order callbacks (aka shaders) we installed on the GPU will procses it.+guiPaintWidgets :: forall id. (Eq id, Ord id) => Wire ImmutaballM ([(id, ((WidthHeightI, GLuint), Rect Double))], M.Map id Double, M.Map id (Widget id), id, Double, IBStateContext) IBStateContext+guiPaintWidgets = proc (paintWidgets, widgetLastFocus, _widgetBy, currentFocusWid, t, cxtn) -> do+	-- let sdlGL1' = sdlGL1 h+	sdlGL1' <- returnA -< liftIBIO . sdlGL1 (cxtn^.ibContext.ibSDLManagerHandle)++	-- Animate grow and shrinking on focus.+	let widgetLastFocus' = M.filter (> t - focusDecayTime) $ widgetLastFocus+	rec+		lastFocusGrow <- delay M.empty -< focusGrow+		focusGrow <- returnA -< M.union ((\lastFocusTime -> lerp focusScale 1.00 (ilerp lastFocusTime (lastFocusTime + focusDecayTime) t)) <$> widgetLastFocus') lastFocusGrow++	let wfocusScale wid_ = fromMaybe (1.00 :: Double) $ M.lookup wid_ focusGrow++	-- Also add a subtle wave on the currently selected widget.+	dt <- differentiate -< t+	smallWave <- wave focusWaveAmplitude 1.0 0.0 -< dt+	let wfocusScale' wid_ = if' (wid_ == currentFocusWid) ((1+smallWave)*) id $ wfocusScale wid_++	-- Shared info.+	let ( sd :: Integer) = fromIntegral $ sizeOf (0.0 :: GLdouble)+	let (_si :: Integer) = fromIntegral $ sizeOf (0   :: GLint)++	let fi = fromIntegral++	--let (vertexStride  :: Integer) = 9*sd + 1*si+	let (vertexStride  :: Integer) = 10*sd+	let (vertexStride' :: GLsizei) = fromIntegral vertexStride++	let (vertexStrideByDoubles :: Integer) = 10++	-- Build vertex data (and element data) to upload to the GPU.++	-- Note that while most of the elements are 8-byte doubles, we want the+	-- texture layers to be interpreted as 4-byte ints, so when constructing these+	-- arrays we do a cast to build the texture layer ints.+	let numWidgets  = genericLength (paintWidgets)+	let trianglesPerWidget = 3+	let verticesPerWidget = 2 * trianglesPerWidget+	let numVertices = numWidgets * verticesPerWidget+	let (vertexArray  :: UArray Integer GLdouble) = runSTUArray $ do+		array_ <- newArray (0, numVertices * vertexStrideByDoubles - 1) 0.0+		when (numWidgets > 0) $ do+			arrayAsGLuint <- castSTUArray' array_+			-- Specify the element type for arrayAsGLuint+			(_firstElem :: GLuint) <- readArray arrayAsGLuint 0++			-- Write the array elements for each widget.+			-- > "layout(location = 0) in vec3 position;",+			-- > "layout(location = 1) in vec4 modulateColor;",+			-- > "layout(location = 2) in vec2 texCoords;",+			-- > "layout(location = 3) in int  texLayer;",+			forM_ (zip [0..] paintWidgets) $ \(idx, (wid_, ((((_w, _h), _texture)), wrect))) -> do+				let (Vec3 vp1 vp2 vp3, Vec3 vp4 vp5 vp6) = rectToTriangles $ wrect & rectAvgSideAboutCenter %~ (wfocusScale' wid_ *)+				let (Vec3 vt1 vt2 vt3, Vec3 vt4 vt5 vt6) = rectToTriangles $ (Rect (Vec2 0.0 0.0) (Vec2 1.0 1.0))++				let withVertex vp vt vidx = do+					-- Position.+					writeArray array_ (vidx*10 + 0) $ vp^.x2+					writeArray array_ (vidx*10 + 1) $ vp^.y2+					writeArray array_ (vidx*10 + 2) $ 0.0+					-- Color.+					if wid_ /= currentFocusWid+						then do+							writeArray array_ (vidx*10 + 3) $ 0.3+							writeArray array_ (vidx*10 + 4) $ 0.3+							writeArray array_ (vidx*10 + 5) $ 0.7+							writeArray array_ (vidx*10 + 6) $ 1.0+						else do+							writeArray array_ (vidx*10 + 3) $ 0.6+							writeArray array_ (vidx*10 + 4) $ 0.6+							writeArray array_ (vidx*10 + 5) $ 0.9+							writeArray array_ (vidx*10 + 6) $ 1.0+					-- Tex coords.+					writeArray array_ (vidx*10 + 7) $ vt^.x2+					writeArray array_ (vidx*10 + 8) $ vt^.y2+					-- Tex layer (double indices since from this view elements are half as long).+					-- (See note near glActiveTexture on the valeu OpenGL uses.)+					--writeArray arrayAsGLuint (2*(vidx*10 + 9) + 0) $ texture+					writeArray arrayAsGLuint (2*(vidx*10 + 9) + 0) $ (fromIntegral idx  :: GLuint)++				withVertex vp1 vt1 (verticesPerWidget * idx + 0)+				withVertex vp2 vt2 (verticesPerWidget * idx + 1)+				withVertex vp3 vt3 (verticesPerWidget * idx + 2)+				withVertex vp4 vt4 (verticesPerWidget * idx + 3)+				withVertex vp5 vt5 (verticesPerWidget * idx + 4)+				withVertex vp6 vt6 (verticesPerWidget * idx + 5)+		return array_+	--let (elementArray :: UArray Integer GLuint)   = runSTUArray $ do+	let (elementArray :: UArray Integer GLuint)   =+		Data.Array.Base.listArray (0, numVertices - 1) [0..(fromIntegral numVertices) - 1]++	(vertexStorableArray  :: StorableArray Integer GLdouble) <- monadic -< liftIBIO $ ThawIO (vertexArray  :: UArray Integer GLdouble) id+	(elementStorableArray :: StorableArray Integer GLuint)   <- monadic -< liftIBIO $ ThawIO (elementArray :: UArray Integer GLuint)   id++	(vertexData  :: GLData) <- monadic -< liftIBIO $ bsToGLData <$> ArrayToBS vertexStorableArray id+	(elementData :: GLData) <- monadic -< liftIBIO $ bsToGLData <$> ArrayToBS elementStorableArray id+	let (numElements_ :: Integer) = fromIntegral $ numElements (elementArray :: UArray Integer GLuint)++	() <- monadic -< sdlGL1' $ do+		-- Disable depth testing.+		GLDisable GL_DEPTH_TEST ()++		-- Before the paint, disable scene data.+		GLUniform1i shaderEnableSceneDataLocation falseAsIntegral ()+		-- Tell the shaders we are not drawing the ball right now.+		GLUniform1i shaderEnableBallDataLocation falseAsIntegral ()++		-- First set the 16 texture name uniforms, and make them active.+		forM_ (zip [0..] $ map (^._2._1._2) paintWidgets) $ \(idx, texture) -> 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 texture ()++		-- Now upload the vertex data and draw.+		vao        <- unSingleton <$> GLGenVertexArrays 1 id+		vertexBuf  <- unSingleton <$> GLGenBuffers      1 id+		elementBuf <- unSingleton <$> GLGenBuffers      1 id++		GLBindVertexArray vao ()++		GLBindBuffer GL_ARRAY_BUFFER vertexBuf                  ()+		GLBufferData GL_ARRAY_BUFFER vertexData GL_DYNAMIC_DRAW ()++		GLBindBuffer GL_ELEMENT_ARRAY_BUFFER elementBuf                  ()+		GLBufferData GL_ELEMENT_ARRAY_BUFFER elementData GL_DYNAMIC_DRAW ()++		-- … stride offset ()++		-- location 0: vec3 positions.+		GLVertexAttribPointer 0 3 GL_DOUBLE GL_FALSE vertexStride' (fi$sum[]*sd) ()+		GLEnableVertexAttribArray 0 ()++		-- location 1: vec4 modulateColors.+		GLVertexAttribPointer 1 4 GL_DOUBLE GL_FALSE vertexStride' (fi$sum[3]*sd) ()+		GLEnableVertexAttribArray 1 ()++		-- location 2: vec2 texCoords.+		GLVertexAttribPointer 2 2 GL_DOUBLE GL_FALSE vertexStride' (fi$sum[3,4]*sd) ()+		GLEnableVertexAttribArray 2 ()++		-- location 3: vec1 texLayers.+		GLVertexAttribIPointer 3 1 GL_INT vertexStride' (fi$sum[3,4,2]*sd) ()+		GLEnableVertexAttribArray 3 ()++		GLDrawElementsRaw GL_TRIANGLES (fromIntegral numElements_) GL_UNSIGNED_INT 0 ()++		GLDeleteBuffers      [vertexBuf]  ()+		GLDeleteBuffers      [elementBuf] ()+		GLDeleteVertexArrays [vao]        ()++	returnA -< cxtn+	where+		unSingleton [me] = me+		unSingleton _    = error "Internal error: guiPaintWidgets expected a single result from GLGenVertexArrays or GLGenBuffers."+		rectToTriangles :: Rect Double -> (Vec3 (Vec2 Double), Vec3 (Vec2 Double))+		rectToTriangles r = (Vec3 (r'^.rectLowerLeft) (r'^.rectLowerRight) (r'^.rectUpperRight), Vec3 (r'^.rectLowerLeft) (r'^.rectUpperLeft) (r'^.rectUpperRight))+			where r' = rectNormalize r++		-- | 'castSTUArray' doesn't update the range.+		-- This version does.  Thus it prevents out of index errors when casting from one array type to another with a different element size.+		-- This version only handles single-dimensional indices.+		castSTUArray' :: forall ix a b s. (Num ix, Integral ix, Storable a, Storable b) => STUArray s ix a -> ST s (STUArray s ix b)+		castSTUArray' (STUArray l u _n marr) = return (STUArray l' u' n' marr)+			where+				btm = error "Internal error: castSTUArray': sizeOf value accessed."+				len = u - l + 1+				len' = ((sa * len) + (sa-1)) `div` sb+					where+						sb = fromIntegral $ sizeOf (btm :: b)+						sa = fromIntegral $ sizeOf (btm :: a)+				-- l and u are actually lower and upper, not length and start.+				u' = l + len' - 1+				l' = l+				n' = fromIntegral $ len'++-- Optionally this could be moved to static config.+focusDecayTime :: Double+focusDecayTime = 0.250++focusScale :: Double+focusScale = 1.100++focusWaveAmplitude :: Double+focusWaveAmplitude = 0.020
+ Immutaball/Share/ImmutaballIO.hs view
@@ -0,0 +1,417 @@+{-# 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 #-}++-- ImmutaballIO.hs.++{-# LANGUAGE Haskell2010 #-}+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, InstanceSigs, ScopedTypeVariables, FlexibleContexts, UndecidableInstances, ExistentialQuantification #-}++-- TODO: also add monad and like instances for BasicIO and SDLIO with a Join+-- like we do here.+-- (Simple IOs like directoryIO probably don't need it.)++module Immutaball.Share.ImmutaballIO+	(+		-- * ImmutaballIO+		ImmutaballIO,+		ImmutaballIOF(..),+		runImmutaballIO,+		andImmutaballIO,+		thenImmutaballIO,+		(<>>),+		(<>>-),+		(<>-),+		joinImmutaballIOF,+		forkIBIOF,+		forkBoundIBIOF,+		forkBothBoundIBIOF,++		-- * mfix+		FixImmutaballIOException(..),+		fixImmutaballIOExceptionToException,+		fixImmutaballIOExceptionFromException,+		PrematureEvaluationFixImmutaballIOException(..),+		EmptyFixImmutaballIOException(..),+		fixImmutaballIOF,+		unsafeFixImmutaballIOFTo,++		-- * Runners+		runImmutaballIOIO,+		runBasicImmutaballIO,+		runDirectoryImmutaballIO,+		runSDLImmutaballIO,+		hArrayToBS,++		-- * ImmutaballIO aliases that apply the Fixed wrapper+		mkEmptyIBIO,+		mkPureIBIO,+		mkUnfixIBIO,+		mkJoinIBIO,+		mkAndIBIO,+		mkThenIBIO,+		mkBasicIBIO,+		mkWait,+		mkWithAsync,+		mkAtomically,+		mkThrowIO,+		mkArrayToBS,+		mkThawIO,+		mkFreezeIO,+		mkPoke,+		mkPeek,++		-- * Utils+		mkBIO+	) where++import Prelude ()+import Immutaball.Prelude++import GHC.Stack        (HasCallStack)      -- For ThrowIO.+--import Foreign.Ptr      (castPtr)           -- (For ArrayToBS.)+--import Foreign.Storable (sizeOf, Storable)  -- (For ArrayToBS.)++import Control.Concurrent.Async+import Control.Monad.Fix+import Control.Monad.STM+import Control.Parallel+import Data.Array.Base+import Data.Array.Storable+import qualified Data.ByteString as BS+import Foreign.Ptr+import Foreign.Storable++import Immutaball.Share.ImmutaballIO.BasicIO+import Immutaball.Share.ImmutaballIO.DirectoryIO+import Immutaball.Share.ImmutaballIO.SDLIO+import Immutaball.Share.Utils++-- (mfix imports.)+import Control.Concurrent.MVar+import Control.Exception+import Data.Typeable+import GHC.IO.Unsafe (unsafeDupableInterleaveIO)+import System.IO.Unsafe (unsafePerformIO)++-- * ImmutaballIO++type ImmutaballIO = Fixed ImmutaballIOF+data ImmutaballIOF me =+	  EmptyIBIOF+	| PureIBIOF me+	| UnfixIBIOF (ImmutaballIOF me)+	| JoinIBIOF (ImmutaballIOF (ImmutaballIOF me))+	| AndIBIOF me me+	| ThenIBIOF me me+	| BasicIBIOF (BasicIOF me)++	| forall hiddenTypeField. Wait (Async hiddenTypeField) (hiddenTypeField -> me)+	| WithAsync me (Async () -> me)+	| forall hiddenTypeField. Atomically (STM hiddenTypeField) (hiddenTypeField -> me)++	| forall e. (HasCallStack, Exception e) => ThrowIO e++	| forall i e. (Integral i, Ix i, Storable e) => ArrayToBS (StorableArray i e) (BS.ByteString -> me)++	| forall a b i e. (Ix i, IArray a e,    MArray b e IO) => ThawIO   (a i e) (b i e -> me)+	| forall a b i e. (Ix i, MArray a e IO, IArray b e)    => FreezeIO (a i e) (b i e -> me)++	| forall a. (Storable a) => Poke (Ptr a) a me+	| forall a. (Storable a) => Peek (Ptr a) (a -> me)++runImmutaballIO :: ImmutaballIO -> IO ()+runImmutaballIO bio = cata runImmutaballIOIO bio++andImmutaballIO :: ImmutaballIO -> ImmutaballIO -> ImmutaballIO +andImmutaballIO x y = Fixed $ AndIBIOF x y++thenImmutaballIO :: ImmutaballIO -> ImmutaballIO -> ImmutaballIO+thenImmutaballIO x y = Fixed $ ThenIBIOF x y++instance Semigroup (ImmutaballIOF ImmutaballIO) where+	(<>) :: ImmutaballIOF ImmutaballIO -> ImmutaballIOF ImmutaballIO -> ImmutaballIOF ImmutaballIO+	a <> b = AndIBIOF (Fixed a) (Fixed b)+instance (Semigroup (ImmutaballIOF me)) => Monoid (ImmutaballIOF me) where+	mempty = EmptyIBIOF++instance Semigroup ImmutaballIO where+	(Fixed a) <> (Fixed b) = Fixed (a <> b)+instance Monoid ImmutaballIO where+	mempty = Fixed EmptyIBIOF++instance Functor ImmutaballIOF where+	fmap :: (a -> b) -> (ImmutaballIOF a -> ImmutaballIOF b)+	fmap _f (EmptyIBIOF)      = EmptyIBIOF+	fmap  f (PureIBIOF a)     = PureIBIOF (f a)+	fmap  f (UnfixIBIOF ibio) = UnfixIBIOF (f <$> ibio)+	fmap  f (JoinIBIOF ibio)  = JoinIBIOF (fmap f <$> ibio)+	fmap  f (AndIBIOF a b)    = AndIBIOF (f a) (f b)+	fmap  f (ThenIBIOF a b)   = ThenIBIOF (f a) (f b)+	fmap  f (BasicIBIOF bio)  = BasicIBIOF $ f <$> bio++	fmap  f (Wait async_ withAsync_)    = Wait async_ (f . withAsync_)+	fmap  f (WithAsync ibio withAsync_) = WithAsync (f ibio) (f . withAsync_)+	fmap  f (Atomically stm withStm)    = Atomically stm (f . withStm)++	fmap _f (ThrowIO e)       = ThrowIO e++	fmap  f (ArrayToBS array_ withBS) = ArrayToBS array_ (f . withBS)++	fmap  f (ThawIO   iarray withMArray) = ThawIO   iarray (f . withMArray)+	fmap  f (FreezeIO marray withIArray) = FreezeIO marray (f . withIArray)++	fmap  f (Poke ptr val withUnit) = Poke ptr val (f withUnit)+	fmap  f (Peek ptr     withVal)  = Peek ptr     (f . withVal)++joinImmutaballIOF :: ImmutaballIOF (ImmutaballIOF a) -> ImmutaballIOF a+joinImmutaballIOF = JoinIBIOF++-- | Fork the first IBIOF, with the result associated with the second IBIOF.+--+-- This is represented as a flipped And, since And is normally understood to+-- have its first _ordinary_ ‘me’ (e.g. not a bound thread like ForkOS) to be+-- the result.  This mostly pertains to mfix: e.g. fix with And takes the first+-- argument as the result, but still expands the tree to traverse through the+-- second too, preserving ‘let ma = ma >>= f’ in a computable manner.  mfix+-- with forkOS takes the second argument as result first, but still traverses+-- the tree all the same.+--+-- Note: due to the underlying 'concurrently_' runner, both branches are run+-- under an unbound thread.+--+-- Use 'forkBoundIBIOF' or 'ForkIO' if instead you wish to keep the primary+-- thread in the second argument bound, but fork the first unbound.  Use+-- 'forkBothboundIBIOF' or 'ForkOS' if you wish to keep both bound.  Ensuring+-- some commands are run in a same bound thread may be necessary e.g. for+-- OpenGL.+forkIBIOF :: ImmutaballIOF me -> ImmutaballIOF me -> ImmutaballIOF me+forkIBIOF fork withUnit = JoinIBIOF $ flip AndIBIOF fork withUnit++-- | Keep the second, main thread in a bound thread if it is running in a bound thread.+--+-- Note the underlying runner does not use 'concurrently_' to manage automatic+-- thread clean-up.  Thus normally 'forkIBIOF' is preferable unless you want to+-- keep the second argument running in a bound thread, e.g. for OpenGL rendering.+--+-- (See 'Control.Concurrent' documentation for what a bound versus unbound+-- thread means.)+forkBoundIBIOF :: ImmutaballIOF me -> ImmutaballIOF me -> ImmutaballIOF me+forkBoundIBIOF fork withUnit = JoinIBIOF . BasicIBIOF $ ForkIO fork withUnit++-- | Fork into a bound thread with 'forkOS'.+forkBothBoundIBIOF :: ImmutaballIOF me -> ImmutaballIOF me -> ImmutaballIOF me+forkBothBoundIBIOF fork withUnit = JoinIBIOF . BasicIBIOF $ ForkOS fork withUnit++-- * mfix++data FixImmutaballIOException = forall e. Exception e => FixImmutaballIOException e+instance Show FixImmutaballIOException where+	show (FixImmutaballIOException e) = show e+instance Exception FixImmutaballIOException+fixImmutaballIOExceptionToException :: Exception e => e -> SomeException+fixImmutaballIOExceptionToException = toException . FixImmutaballIOException+fixImmutaballIOExceptionFromException :: Exception e => SomeException -> Maybe e+fixImmutaballIOExceptionFromException x = do+	FixImmutaballIOException a <- fromException x+	cast a++-- | Premature evaluation or attempt to access an empty value (e.g. mfix with EmptyIBIOF).+data PrematureEvaluationFixImmutaballIOException = PrematureEvaluationFixImmutaballIOException+	deriving (Show)+instance Exception PrematureEvaluationFixImmutaballIOException where+	toException = fixImmutaballIOExceptionToException+	fromException = fixImmutaballIOExceptionFromException++data EmptyFixImmutaballIOException = EmptyFixImmutaballIOException+	deriving (Show)+instance Exception EmptyFixImmutaballIOException where+	toException = fixImmutaballIOExceptionToException+	fromException = fixImmutaballIOExceptionFromException++--    mfix f = mfix f >>= f+-- => mfix f = join $ f <$> mfix f+-- Incorrect: runs f twice.+	--x -> f undefined >>= mfix f+{-+fixImmutaballIOF :: (me -> ImmutaballIOF me) -> ImmutaballIOF me+fixImmutaballIOF f = case f (error "Error: fixImmutaballIOF: premature evaluation of result before we could start it!") of+	x -> joinImmutaballIOF $ f <$> x+-}+-- Do it like fixIO and fixST (see also their notes; it's a little tricky).+-- Use a lazily read MVar.+fixImmutaballIOF :: (me -> ImmutaballIOF me) -> ImmutaballIOF me+fixImmutaballIOF f = unsafePerformIO $ do+	mme <- newEmptyMVar+	return $ unsafeFixImmutaballIOFTo mme f++-- | Helper for fixImmutaballIOF.+unsafeFixImmutaballIOFTo :: MVar me -> (me -> ImmutaballIOF me) -> ImmutaballIOF me+unsafeFixImmutaballIOFTo mme f = unsafePerformIO $ do+	me_ <- unsafeDupableInterleaveIO (readMVar mme `catch` \BlockedIndefinitelyOnMVar -> throwIO PrematureEvaluationFixImmutaballIOException)+	case f me_ of+		--_y@(EmptyIBIOF)        -> throwIO EmptyFixImmutaballIOException+		_y@(EmptyIBIOF)        -> return $ EmptyIBIOF+		y@(PureIBIOF a)        -> putMVar mme a >> return y+		_y@(UnfixIBIOF ibio)   -> return . UnfixIBIOF . unsafeFixImmutaballIOFTo mme $ const ibio+		-- Join: Cover all multi-branching (or else we could hang on multiple putMVars), then just fmap for all other cases.+		_y@(JoinIBIOF (AndIBIOF a b)) -> return (JoinIBIOF (AndIBIOF (unsafeFixImmutaballIOFTo mme (const a)) (JoinIBIOF $ f <$> b)))+		_y@(JoinIBIOF (ThenIBIOF a b)) -> return (JoinIBIOF (ThenIBIOF (unsafeFixImmutaballIOFTo mme (const a)) (JoinIBIOF $ f <$> b)))+		_y@(JoinIBIOF ibio)    -> return $ JoinIBIOF (unsafeFixImmutaballIOFTo mme . const <$> ibio)+		_y@(AndIBIOF  a b)     -> putMVar mme a >> return (JoinIBIOF $ AndIBIOF  (PureIBIOF a) (f b))+		_y@(ThenIBIOF a b)     -> putMVar mme a >> return (JoinIBIOF $ ThenIBIOF (PureIBIOF a) (f b))+		_y@(BasicIBIOF bio)    -> return . BasicIBIOF . unsafeFixBasicIOFTo mme $ const bio++		_y@(Wait async_ withAsync_)    -> return $ Wait       async_ ((\me -> unsafePerformIO $ putMVar mme me >> return me) . withAsync_)+		_y@(WithAsync ibio withAsync_) -> return $ WithAsync  ibio   ((\me -> unsafePerformIO $ putMVar mme me >> return me) . withAsync_)+		_y@(Atomically stm withStm)    -> return $ Atomically stm    ((\me -> unsafePerformIO $ putMVar mme me >> return me) . withStm)++		--y@(ThrowIO _e me) -> putMVar mme me >> return y+		_y@(ThrowIO e) -> return $ ThrowIO e++		_y@(ArrayToBS array_ withBS) -> return $ ArrayToBS array_ ((\me -> unsafePerformIO $ putMVar mme me >> return me) . withBS)++		_y@(ThawIO   iarray withMArray) -> return $ ThawIO   iarray ((\me -> unsafePerformIO $ putMVar mme me >> return me) . withMArray)+		_y@(FreezeIO marray withIArray) -> return $ FreezeIO marray ((\me -> unsafePerformIO $ putMVar mme me >> return me) . withIArray)++		y@( Poke _ptr _val me)      -> putMVar mme me >> return y+		_y@(Peek ptr       withVal) -> return $ Peek ptr ((\me -> unsafePerformIO $ putMVar mme me >> return me) . withVal)++instance Applicative ImmutaballIOF where+	pure = PureIBIOF+	mf <*> ma = joinImmutaballIOF . flip fmap mf $ \f -> joinImmutaballIOF .  flip fmap ma $ \a -> pure (f a)+instance Monad ImmutaballIOF where+	return = pure+	m >>= f = joinImmutaballIOF $ f <$> m+instance MonadFix ImmutaballIOF where+	mfix :: (a -> ImmutaballIOF a) -> ImmutaballIOF a+	mfix = fixImmutaballIOF++{-+instance Foldable ImmutaballIOF where+	foldr :: (a -> b -> b) -> b -> ImmutaballIOF a -> b+	foldr _reduce reduction0 (EmptyIBIOF)  = reduction0+	foldr  reduce reduction0 (PureIBIOF a) = reduce a reduction0+	foldr  reduce reduction0 (JoinIBIOF ibio) = ??? $ foldr reduce reduction0 <$> ibio+-}++-- | Add an ordering constraint.+infixr 6 <>>+(<>>) :: ImmutaballIO -> ImmutaballIO -> ImmutaballIO+(<>>) = thenImmutaballIO++-- | A more general version.+infixr 6 <>>-+(<>>-) :: ImmutaballIOF me -> ImmutaballIOF me -> ImmutaballIOF me+a <>>- b = JoinIBIOF $ a `ThenIBIOF` b++-- | Without an ordering constraint.+infixr 6 <>-+(<>-) :: ImmutaballIOF me -> ImmutaballIOF me -> ImmutaballIOF me+a <>- b = JoinIBIOF $ a `AndIBIOF` b++-- * Runners++runImmutaballIOIO :: ImmutaballIOF (IO ()) -> IO ()++runImmutaballIOIO (EmptyIBIOF)      = return ()+runImmutaballIOIO (PureIBIOF a)     = a+runImmutaballIOIO (UnfixIBIOF ibio) = runImmutaballIOIO ibio+runImmutaballIOIO (JoinIBIOF ibio)  = runImmutaballIOIO $ runImmutaballIOIO <$> ibio+runImmutaballIOIO (AndIBIOF a b)    = a `par` b `par` concurrently_ a b+runImmutaballIOIO (ThenIBIOF a b)   = a >> b+runImmutaballIOIO (BasicIBIOF bio)  = runBasicIOIO bio++runImmutaballIOIO (Wait async_ withAsync_)    = wait async_ >>= withAsync_+runImmutaballIOIO (WithAsync ibio withAsync_) = withAsync ibio withAsync_+runImmutaballIOIO (Atomically stm withStm)    = atomically stm >>= withStm++runImmutaballIOIO (ThrowIO e) = throwIO e++runImmutaballIOIO (ArrayToBS array_ withBS) = hArrayToBS array_ >>= withBS++runImmutaballIOIO (ThawIO   iarray withMArray) = thaw   iarray >>= withMArray+runImmutaballIOIO (FreezeIO marray withIArray) = freeze marray >>= withIArray++runImmutaballIOIO (Poke ptr val ibio)    = poke ptr val >> ibio+runImmutaballIOIO (Peek ptr     withVal) = peek ptr     >>= withVal++runBasicImmutaballIO :: BasicIO -> ImmutaballIO+runBasicImmutaballIO bio = Fixed $ BasicIBIOF (runBasicImmutaballIO <$> getFixed bio)++runDirectoryImmutaballIO :: DirectoryIO -> ImmutaballIO+runDirectoryImmutaballIO dio = runBasicImmutaballIO . runDirectoryBasicIO $ dio++runSDLImmutaballIO :: SDLIO -> ImmutaballIO+runSDLImmutaballIO sdlio = runBasicImmutaballIO . runSDLBasicIO $ sdlio++-- | Copy an array to an immutable strict bytestring.+hArrayToBS :: (Integral i, Ix i, Storable e) => StorableArray i e -> IO BS.ByteString+hArrayToBS array_ = do+	(len :: Integer) <- fromIntegral <$> getNumElements array_+	size <- do+		if len <= 0+			then return 0+			else do+				arrayHead <- readArray array_ (fromIntegral (0 :: Integer))+				let elemSize = fromIntegral $ sizeOf arrayHead+				let size_ = len * elemSize+				return size_+	bs <- withStorableArray array_ $ \ptr -> BS.packCStringLen ((castPtr ptr), fromIntegral $ size)+	return bs++-- * ImutaballIO aliases that apply the Fixed wrapper++mkEmptyIBIO :: ImmutaballIO+mkEmptyIBIO = Fixed $ EmptyIBIOF++mkPureIBIO :: ImmutaballIO -> ImmutaballIO+mkPureIBIO ibio = Fixed $ PureIBIOF ibio++mkUnfixIBIO :: ImmutaballIO -> ImmutaballIO+mkUnfixIBIO ibio = Fixed $ UnfixIBIOF (getFixed ibio)++mkJoinIBIO :: ImmutaballIO -> ImmutaballIO+mkJoinIBIO ibio = Fixed $ JoinIBIOF (getFixed <$> getFixed ibio)++mkAndIBIO :: ImmutaballIO -> ImmutaballIO -> ImmutaballIO+mkAndIBIO a b = Fixed $ AndIBIOF a b++mkThenIBIO :: ImmutaballIO -> ImmutaballIO -> ImmutaballIO+mkThenIBIO a b = Fixed $ ThenIBIOF a b++mkBasicIBIO :: BasicIOF ImmutaballIO -> ImmutaballIO+mkBasicIBIO bio = Fixed $ BasicIBIOF bio++mkWait :: Async a -> (a -> ImmutaballIO) -> ImmutaballIO+mkWait async_ withAsync_ = Fixed $ Wait async_ withAsync_++mkWithAsync :: ImmutaballIO -> (Async () -> ImmutaballIO) -> ImmutaballIO+mkWithAsync ibio withAsync_ = Fixed $ WithAsync ibio withAsync_++mkAtomically :: STM a -> (a -> ImmutaballIO) -> ImmutaballIO+mkAtomically stm withStm = Fixed $ Atomically stm withStm++mkThrowIO :: (HasCallStack, Exception e) => e -> ImmutaballIO+mkThrowIO e = Fixed $ ThrowIO e++mkArrayToBS :: (Integral i, Ix i, Storable e) => StorableArray i e -> (BS.ByteString -> ImmutaballIO) -> ImmutaballIO+mkArrayToBS array_ withBS = Fixed $ ArrayToBS array_ withBS++mkThawIO :: (Ix i, IArray a e, MArray b e IO) => a i e -> (b i e -> ImmutaballIO) -> ImmutaballIO+mkThawIO iarray withMArray = Fixed $ ThawIO iarray withMArray++mkFreezeIO :: (Ix i, MArray a e IO, IArray b e) => a i e -> (b i e -> ImmutaballIO) -> ImmutaballIO+mkFreezeIO marray withIArray = Fixed $ FreezeIO marray withIArray++mkPoke :: (Storable a) => Ptr a -> a -> ImmutaballIO -> ImmutaballIO+mkPoke ptr val ibio = Fixed $ Poke ptr val ibio++mkPeek :: (Storable a) => Ptr a -> (a -> ImmutaballIO) -> ImmutaballIO+mkPeek ptr withVal = Fixed $ Peek ptr withVal++-- * Utils++-- | Short alias for 'mkBasicImmutaballIO'.+mkBIO :: BasicIOF ImmutaballIO -> ImmutaballIO+mkBIO = mkBasicIBIO
+ Immutaball/Share/ImmutaballIO/BasicIO.hs view
@@ -0,0 +1,476 @@+{-# 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 #-}++-- ImmutaballIO/Basic.hs.++{-# LANGUAGE Haskell2010 #-}+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, InstanceSigs, ScopedTypeVariables, ExistentialQuantification #-}++module Immutaball.Share.ImmutaballIO.BasicIO+	(+		-- * BasicIO+		BasicIO,+		BasicIOF(..),+		runBasicIO,+		(-<>>),++		-- * mfix+		FixBasicIOException(..),+		fixBasicIOExceptionToException,+		fixBasicIOExceptionFromException,+		PrematureEvaluationFixBasicIOException(..),+		EmptyFixBasicIOException(..),+		fixBasicIOF,+		unsafeFixBasicIOFTo,++		-- * Runners+		runBasicIOIO,+		runDirectoryBasicIO,+		runSDLBasicIO,+		runGLBasicIO,+		hReadBytesSync,+		hReadTextSync,++		-- * BasicIO aliases that apply the Fixed wrapper+		mkEmptyBasicIO,+		mkPureBasicIO,+		mkUnfixBasicIO,+		mkJoinBasicIO,+		mkAndBasicIO,+		mkThenBasicIO,+		mkExitSuccessBasicIO,+		mkExitFailureBasicIO,+		mkDirectoryIO,+		mkGetArgs,+		mkGetArgsSync,+		mkGetEnvironment,+		mkGetEnvironmentSync,+		mkPutStrLn,+		mkGetContents,+		mkGetContentsSync,+		mkDoesPathExist,+		mkDoesPathExistSync,+		mkWriteBytes,+		mkWriteText,+		mkReadBytes,+		mkReadBytesSync,+		mkReadText,+		mkReadTextSync,+		mkCreateDirectoryIfMissing,+		mkGetDirectoryContents,+		mkGetDirectoryContentsSync,+		mkForkIO,+		mkForkOS,+		mkSDLIO,+		mkGLIO,+		mkDelayUs,+		mkGetUs,++		-- * Utils+		getUsIO+	) where++import Prelude ()+import Immutaball.Prelude++import Control.Concurrent+--import Control.Exception (catch, throwIO)+import Control.Monad+import Control.Monad.Fix+import Data.Time.Clock.System+import System.Environment+import System.Exit++import Control.Concurrent.Async+import Control.Concurrent.Thread.Delay+import Control.Parallel+import qualified Data.ByteString.Lazy as BL+import qualified Data.Text as T+import qualified Data.Text.IO.Utf8 as TIO+import System.Directory++import Immutaball.Share.ImmutaballIO.DirectoryIO+import Immutaball.Share.ImmutaballIO.GLIO+import Immutaball.Share.ImmutaballIO.SDLIO+import Immutaball.Share.Utils++-- (mfix imports.)+--import Control.Concurrent.MVar+import Control.Exception+import Data.Typeable+import GHC.IO.Unsafe (unsafeDupableInterleaveIO)+import System.IO.Unsafe (unsafePerformIO)++-- * BasicIO++type BasicIO = Fixed BasicIOF+data BasicIOF me =+	  EmptyBasicIOF+	| PureBasicIOF me+	| UnfixBasicIOF (BasicIOF me)+	| JoinBasicIOF (BasicIOF (BasicIOF me))+	| AndBasicIOF me me+	| ThenBasicIOF me me+	| ExitSuccessBasicIOF+	| ExitFailureBasicIOF++	| DirectoryIO (DirectoryIOF me)++	| GetArgs (Async [String] -> me)+	| GetArgsSync ([String] -> me)+	| GetEnvironment (Async [(String, String)] -> me)+	| GetEnvironmentSync ([(String, String)] -> me)+	| PutStrLn String me+	| GetContents (Async String -> me)+	| GetContentsSync (String -> me)++	| DoesPathExist FilePath (Async Bool -> me)+	| DoesPathExistSync FilePath (Bool -> me)+	| WriteBytes FilePath BL.ByteString me+	| WriteText FilePath T.Text me+	-- | Optional error handler.+	| ReadBytes FilePath (Async (Either IOException BL.ByteString) -> me)+	| ReadBytesSync FilePath (Either IOException BL.ByteString -> me)+	-- | Optional error handler.+	| ReadText FilePath (Async (Either IOException T.Text) -> me)+	| ReadTextSync FilePath (Either IOException T.Text -> me)+	| CreateDirectoryIfMissing FilePath me+	| GetDirectoryContents FilePath (Async [FilePath] -> me)+	| GetDirectoryContentsSync FilePath ([FilePath] -> me)+	| ForkIO me me+	| ForkOS me me++	| SDLIO (SDLIOF me)+	| GLIO (GLIOF me)++	| DelayUs Integer me+	| GetUs (Integer -> me)++runBasicIO :: BasicIO -> IO ()+runBasicIO bio = cata runBasicIOIO bio++instance Semigroup (BasicIOF BasicIO) where+	a <> b = Fixed a `AndBasicIOF` Fixed b+instance Monoid (BasicIOF BasicIO) where+	mempty = EmptyBasicIOF++instance Semigroup BasicIO where+	(Fixed a) <> (Fixed b) = Fixed (a <> b)+instance Monoid BasicIO where+	mempty = Fixed mempty++instance Functor BasicIOF where+	fmap :: (a -> b) -> (BasicIOF a -> BasicIOF b)+	fmap _f (EmptyBasicIOF)       = EmptyBasicIOF+	fmap  f (PureBasicIOF a)      = PureBasicIOF (f a)+	fmap  f (UnfixBasicIOF bio)   = UnfixBasicIOF (f <$> bio)+	fmap  f (JoinBasicIOF bio)    = JoinBasicIOF (fmap f <$> bio)+	fmap  f (AndBasicIOF a b)     = AndBasicIOF (f a) (f b)+	fmap  f (ThenBasicIOF a b)    = ThenBasicIOF (f a) (f b)+	fmap _f (ExitFailureBasicIOF) = ExitFailureBasicIOF+	fmap _f (ExitSuccessBasicIOF) = ExitSuccessBasicIOF++	fmap  f (DirectoryIO dio) = DirectoryIO (f <$> dio)++	fmap  f (GetArgs withArgs_)                  = GetArgs (f . withArgs_)+	fmap  f (GetArgsSync withArgs_)              = GetArgsSync (f . withArgs_)+	fmap  f (GetEnvironment withEnvironment)     = GetEnvironment (f . withEnvironment)+	fmap  f (GetEnvironmentSync withEnvironment) = GetEnvironmentSync (f . withEnvironment)+	fmap  f (PutStrLn str withUnit)              = PutStrLn str (f withUnit)+	fmap  f (GetContents withContents)           = GetContents (f . withContents)+	fmap  f (GetContentsSync withContents)       = GetContentsSync (f . withContents)++	fmap  f (DoesPathExist path withExists)             = DoesPathExist path (f .  withExists)+	fmap  f (DoesPathExistSync path withExists)         = DoesPathExistSync path (f .  withExists)+	fmap  f (WriteBytes path contents withUnit)         = WriteBytes path contents (f withUnit)+	fmap  f (WriteText path contents withUnit)          = WriteText path contents (f withUnit)+	fmap  f (ReadBytes path withContents)               = ReadBytes path (f . withContents)+	fmap  f (ReadBytesSync path withContents)           = ReadBytesSync path (f . withContents)+	fmap  f (ReadText path withContents)                = ReadText path (f . withContents)+	fmap  f (ReadTextSync path withContents)            = ReadTextSync path (f . withContents)+	fmap  f (CreateDirectoryIfMissing path withUnit)    = CreateDirectoryIfMissing path (f withUnit)+	fmap  f (GetDirectoryContents path withEntries)     = GetDirectoryContents path (f . withEntries)+	fmap  f (GetDirectoryContentsSync path withEntries) = GetDirectoryContentsSync path (f . withEntries)+	fmap  f (ForkIO bio withUnit)                       = ForkIO (f bio) (f withUnit)+	fmap  f (ForkOS bio withUnit)                       = ForkOS (f bio) (f withUnit)++	fmap  f (SDLIO sdlio) = SDLIO (f <$> sdlio)+	fmap  f (GLIO glio)   = GLIO  (f <$> glio)++	fmap  f (DelayUs us withUnit) = DelayUs us (f withUnit)+	fmap  f (GetUs withUs)        = GetUs (f . withUs)++instance Applicative BasicIOF where+	pure = PureBasicIOF+	mf <*> ma = JoinBasicIOF . flip fmap mf $ \f -> JoinBasicIOF .  flip fmap ma $ \a -> pure (f a)+instance Monad BasicIOF where+	return = pure+	m >>= f = JoinBasicIOF $ f <$> m+instance MonadFix BasicIOF where+	mfix :: (a -> BasicIOF a) -> BasicIOF a+	mfix = fixBasicIOF++{-+instance Foldable BasicIOF where+	-- TODO+instance Traversable BasicIOF where+	-- TODO+-}++-- | Add an ordering constraint.+infixr 6 -<>>+(-<>>) :: BasicIO -> BasicIO -> BasicIO+(-<>>) = mkThenBasicIO++-- * mfix++data FixBasicIOException = forall e. Exception e => FixBasicIOException e+instance Show FixBasicIOException where+	show (FixBasicIOException e) = show e+instance Exception FixBasicIOException+fixBasicIOExceptionToException :: Exception e => e -> SomeException+fixBasicIOExceptionToException = toException . FixBasicIOException+fixBasicIOExceptionFromException :: Exception e => SomeException -> Maybe e+fixBasicIOExceptionFromException x = do+	FixBasicIOException a <- fromException x+	cast a++data PrematureEvaluationFixBasicIOException = PrematureEvaluationFixBasicIOException+	deriving (Show)+instance Exception PrematureEvaluationFixBasicIOException where+	toException = fixBasicIOExceptionToException+	fromException = fixBasicIOExceptionFromException++data EmptyFixBasicIOException = EmptyFixBasicIOException+	deriving (Show)+instance Exception EmptyFixBasicIOException where+	toException = fixBasicIOExceptionToException+	fromException = fixBasicIOExceptionFromException++--    mfix f = mfix f >>= f+-- => mfix f = join $ f <$> mfix f+-- Incorrect: runs f twice.+	--x -> f undefined >>= mfix f+{-+fixBasicIOF :: (me -> BasicIOF me) -> BasicIOF me+fixBasicIOF f = case f (error "Error: fixBasicIOF: premature evaluation of result before we could start it!") of+	x -> joinBasicIOF $ f <$> x+-}+-- Do it like fixIO and fixST (see also their notes; it's a little tricky).+-- Use a lazily read MVar.+fixBasicIOF :: (me -> BasicIOF me) -> BasicIOF me+fixBasicIOF f = unsafePerformIO $ do+	mme <- newEmptyMVar+	return $ unsafeFixBasicIOFTo mme f++-- | Helper for fixBasicIOF.+unsafeFixBasicIOFTo :: MVar me -> (me -> BasicIOF me) -> BasicIOF me+unsafeFixBasicIOFTo mme f = unsafePerformIO $ do+	me_ <- unsafeDupableInterleaveIO (readMVar mme `catch` \BlockedIndefinitelyOnMVar -> throwIO PrematureEvaluationFixBasicIOException)+	case f me_ of+		--_y@(EmptyBasicIOF)       -> throwIO EmptyFixBasicIOException+		_y@(EmptyBasicIOF)       -> return $ EmptyBasicIOF+		y@( PureBasicIOF a)      -> putMVar mme a >> return y+		_y@(UnfixBasicIOF bio)   -> return . UnfixBasicIOF . unsafeFixBasicIOFTo mme $ const bio+		-- Join: Cover all multi-branching (or else we could hang on multiple putMVars), then just fmap for all other cases.+		_y@(JoinBasicIOF (AndBasicIOF a b)) -> return (JoinBasicIOF (AndBasicIOF (unsafeFixBasicIOFTo mme (const a)) (JoinBasicIOF $ f <$> b)))+		_y@(JoinBasicIOF (ThenBasicIOF a b)) -> return (JoinBasicIOF (ThenBasicIOF (unsafeFixBasicIOFTo mme (const a)) (JoinBasicIOF $ f <$> b)))+		_y@(JoinBasicIOF ibio)    -> return $ JoinBasicIOF (unsafeFixBasicIOFTo mme . const <$> ibio)+		_y@(AndBasicIOF  a b)    -> putMVar mme a >> return (JoinBasicIOF $ AndBasicIOF (PureBasicIOF a) (f b))+		_y@(ThenBasicIOF a b)    -> putMVar mme a >> return (JoinBasicIOF $ ThenBasicIOF (PureBasicIOF a) (f b))+		--_y@(ExitSuccessBasicIOF) -> throwIO EmptyFixBasicIOException+		--_y@(ExitFailureBasicIOF) -> throwIO EmptyFixBasicIOException+		_y@(ExitSuccessBasicIOF) -> return $ ExitSuccessBasicIOF+		_y@(ExitFailureBasicIOF) -> return $ ExitFailureBasicIOF++		_y@(DirectoryIO dio) -> return . DirectoryIO . unsafeFixDirectoryIOFTo mme $ const dio++		_y@(GetArgs            withArgs_)       -> return $ GetArgs            ((\me -> unsafePerformIO $ putMVar mme me >> return me) . withArgs_)+		_y@(GetArgsSync        withArgs_)       -> return $ GetArgsSync        ((\me -> unsafePerformIO $ putMVar mme me >> return me) . withArgs_)+		_y@(GetEnvironment     withEnvironment) -> return $ GetEnvironment     ((\me -> unsafePerformIO $ putMVar mme me >> return me) . withEnvironment)+		_y@(GetEnvironmentSync withEnvironment) -> return $ GetEnvironmentSync ((\me -> unsafePerformIO $ putMVar mme me >> return me) . withEnvironment)+		y@( PutStrLn           _str me)         -> putMVar mme me >> return y+		_y@(GetContents        withContents)    -> return $ GetContents        ((\me -> unsafePerformIO $ putMVar mme me >> return me) . withContents)+		_y@(GetContentsSync    withContents)    -> return $ GetContentsSync    ((\me -> unsafePerformIO $ putMVar mme me >> return me) . withContents)++		_y@(DoesPathExist     path withExists)            -> return $ DoesPathExist     path ((\me -> unsafePerformIO $ putMVar mme me >> return me) . withExists)+		_y@(DoesPathExistSync path withExists)            -> return $ DoesPathExistSync path ((\me -> unsafePerformIO $ putMVar mme me >> return me) . withExists)+		y@( WriteBytes        _path _contents me)         -> putMVar mme me >> return y+		y@( WriteText         _path _contents me)         -> putMVar mme me >> return y+		_y@(ReadBytes         path withContents)          -> return $ ReadBytes         path ((\me -> unsafePerformIO $ putMVar mme me >> return me) . withContents)+		_y@(ReadBytesSync     path withContents)          -> return $ ReadBytesSync     path ((\me -> unsafePerformIO $ putMVar mme me >> return me) . withContents)+		_y@(ReadText          path withContents)          -> return $ ReadText          path ((\me -> unsafePerformIO $ putMVar mme me >> return me) . withContents)+		_y@(ReadTextSync      path withContents)          -> return $ ReadTextSync      path ((\me -> unsafePerformIO $ putMVar mme me >> return me) . withContents)+		y@( CreateDirectoryIfMissing _path me)            -> putMVar mme me >> return y+		_y@(GetDirectoryContents path withEntries)        -> return $ GetDirectoryContents path ((\me -> unsafePerformIO $ putMVar mme me >> return me) . withEntries)+		_y@(GetDirectoryContentsSync path withEntries)    -> return $ GetDirectoryContentsSync path ((\me -> unsafePerformIO $ putMVar mme me >> return me) . withEntries)+		--y@( ForkIO            _bio me)                    -> putMVar mme me >> return y+		_y@(ForkIO            bio me)                     -> putMVar mme me >> return (JoinBasicIOF $ ForkIO (f bio) (PureBasicIOF me))+		--y@( ForkOS            _os me)                     -> putMVar mme me >> return y+		_y@(ForkOS            os me)                      -> putMVar mme me >> return (JoinBasicIOF $ ForkOS (f os)  (PureBasicIOF me))++		_y@(SDLIO sdlio) -> return . SDLIO . unsafeFixSDLIOFTo mme $ const sdlio+		_y@(GLIO  glio)  -> return . GLIO  . unsafeFixGLIOFTo  mme $ const glio++		y@( DelayUs _us me) -> putMVar mme me >> return y+		_y@(GetUs   withUs) -> return $ GetUs ((\me -> unsafePerformIO $ putMVar mme me >> return me) . withUs)++-- * Runners++runBasicIOIO :: BasicIOF (IO ()) -> IO ()+runBasicIOIO (EmptyBasicIOF)                          = return ()+runBasicIOIO (PureBasicIOF bio)                       = bio+runBasicIOIO (UnfixBasicIOF bio)                      = runBasicIOIO bio+runBasicIOIO (JoinBasicIOF bio)                       = runBasicIOIO $ runBasicIOIO <$> bio+runBasicIOIO (AndBasicIOF a b)                        = a `par` b `par` concurrently_ a b+runBasicIOIO (ThenBasicIOF a b)                       = a >> b+runBasicIOIO (ExitSuccessBasicIOF)                    = exitSuccess+runBasicIOIO (ExitFailureBasicIOF)                    = exitFailure+runBasicIOIO (DirectoryIO dio)                        = runDirectoryIOIO $ dio+runBasicIOIO (GetArgs withArgs_)                      = withAsync getArgs withArgs_+runBasicIOIO (GetArgsSync withArgs_)                  = getArgs >>= withArgs_+runBasicIOIO (GetEnvironment withEnvironment)         = withAsync getEnvironment withEnvironment+runBasicIOIO (GetEnvironmentSync withEnvironment)     = getEnvironment >>= withEnvironment+runBasicIOIO (PutStrLn str withUnit)                  = putStrLn str >> withUnit+runBasicIOIO (GetContents withContents)               = withAsync getContents withContents+runBasicIOIO (GetContentsSync withContents)           = getContents >>= withContents+runBasicIOIO (DoesPathExist path withExists)          = withAsync (doesPathExist path) withExists+runBasicIOIO (DoesPathExistSync path withExists)      = doesPathExist path >>= withExists+runBasicIOIO (WriteBytes path contents withUnit)      = BL.writeFile path contents >> withUnit+runBasicIOIO (WriteText path contents withUnit)       = TIO.writeFile path contents >> withUnit+runBasicIOIO (ReadBytes path withContents)            = withAsync (hReadBytesSync path) withContents+runBasicIOIO (ReadBytesSync path withContents)        = hReadBytesSync path >>= withContents+runBasicIOIO (ReadText path withContents)             = withAsync (hReadTextSync path) withContents+runBasicIOIO (ReadTextSync path withContents)         = hReadTextSync path >>= withContents+runBasicIOIO (CreateDirectoryIfMissing path withUnit) = createDirectoryIfMissing True path >> withUnit+runBasicIOIO (GetDirectoryContents path withEntries)  = withAsync (getDirectoryContents path) withEntries+runBasicIOIO (GetDirectoryContentsSync path withEntries) = getDirectoryContents path >>= withEntries+runBasicIOIO (ForkIO bio withUnit)                    = (void . forkIO) bio >> withUnit+runBasicIOIO (ForkOS bio withUnit)                    = (void . forkOS) bio >> withUnit+runBasicIOIO (SDLIO sdlio)                            = runSDLIOIO $ sdlio+runBasicIOIO (GLIO  glio)                             = runGLIOIO  $ glio+runBasicIOIO (DelayUs us withUnit)                    = delay us >> withUnit+runBasicIOIO (GetUs withUs)                           = getUsIO >>= withUs++runDirectoryBasicIO :: DirectoryIO -> BasicIO+runDirectoryBasicIO dio = Fixed . DirectoryIO $ runDirectoryBasicIO <$> getFixed dio++runSDLBasicIO :: SDLIO -> BasicIO+runSDLBasicIO sdlio = Fixed . SDLIO $ runSDLBasicIO <$> getFixed sdlio++runGLBasicIO :: GLIO -> BasicIO+runGLBasicIO glio = Fixed . GLIO $ runGLBasicIO <$> getFixed glio++hReadBytesSync :: FilePath -> IO (Either IOException BL.ByteString)+hReadBytesSync path = try $ BL.readFile path++hReadTextSync :: FilePath -> IO (Either IOException T.Text)+hReadTextSync path = try $ TIO.readFile path++-- * ImutaballIO aliases that apply the Fixed wrapper++mkEmptyBasicIO :: BasicIO+mkEmptyBasicIO = Fixed $ EmptyBasicIOF++mkPureBasicIO :: BasicIO -> BasicIO+mkPureBasicIO bio = Fixed $ PureBasicIOF bio++mkUnfixBasicIO :: BasicIO -> BasicIO+mkUnfixBasicIO bio = Fixed $ UnfixBasicIOF (getFixed bio)++mkJoinBasicIO :: BasicIO -> BasicIO+mkJoinBasicIO bio = Fixed $ JoinBasicIOF (getFixed <$> getFixed bio)++mkAndBasicIO :: BasicIO -> BasicIO -> BasicIO+mkAndBasicIO a b = Fixed $ AndBasicIOF a b++mkThenBasicIO :: BasicIO -> BasicIO -> BasicIO+mkThenBasicIO a b = Fixed $ ThenBasicIOF a b++mkExitSuccessBasicIO :: BasicIO+mkExitSuccessBasicIO = Fixed $ ExitFailureBasicIOF++mkExitFailureBasicIO :: BasicIO+mkExitFailureBasicIO = Fixed $ ExitFailureBasicIOF++mkDirectoryIO :: DirectoryIOF BasicIO -> BasicIO+mkDirectoryIO dio = Fixed $ DirectoryIO dio++mkGetArgs :: (Async [String] -> BasicIO) -> BasicIO+mkGetArgs withArgs_ = Fixed $ GetArgs withArgs_++mkGetArgsSync :: ([String] -> BasicIO) -> BasicIO+mkGetArgsSync withArgs_ = Fixed $ GetArgsSync withArgs_++mkGetEnvironment :: (Async [(String, String)] -> BasicIO) -> BasicIO+mkGetEnvironment withEnvironment = Fixed $ GetEnvironment withEnvironment++mkGetEnvironmentSync :: ([(String, String)] -> BasicIO) -> BasicIO+mkGetEnvironmentSync withEnvironment = Fixed $ GetEnvironmentSync withEnvironment++mkPutStrLn :: String -> BasicIO -> BasicIO+mkPutStrLn str bio = Fixed $ PutStrLn str bio++mkGetContents :: (Async String -> BasicIO) -> BasicIO+mkGetContents withContents = Fixed $ GetContents withContents++mkGetContentsSync :: (String -> BasicIO) -> BasicIO+mkGetContentsSync withContents = Fixed $ GetContentsSync withContents++mkDoesPathExist :: FilePath -> (Async Bool -> BasicIO) -> BasicIO+mkDoesPathExist path withExists = Fixed $ DoesPathExist path withExists++mkDoesPathExistSync :: FilePath -> (Bool -> BasicIO) -> BasicIO+mkDoesPathExistSync path withExists = Fixed $ DoesPathExistSync path withExists++mkWriteBytes :: FilePath -> BL.ByteString -> BasicIO -> BasicIO+mkWriteBytes path contents withUnit = Fixed $ WriteBytes path contents withUnit++mkWriteText :: FilePath -> T.Text -> BasicIO -> BasicIO+mkWriteText path contents withUnit = Fixed $ WriteText path contents withUnit++mkReadBytes :: FilePath -> (Async (Either IOException BL.ByteString) -> BasicIO) -> BasicIO+mkReadBytes path withContents = Fixed $ ReadBytes path withContents++mkReadBytesSync :: FilePath -> (Either IOException BL.ByteString -> BasicIO) -> BasicIO+mkReadBytesSync path withContents = Fixed $ ReadBytesSync path withContents++mkReadText :: FilePath -> (Async (Either IOException T.Text) -> BasicIO) -> BasicIO+mkReadText path withContents = Fixed $ ReadText path withContents++mkReadTextSync :: FilePath -> (Either IOException T.Text -> BasicIO) -> BasicIO+mkReadTextSync path withContents = Fixed $ ReadTextSync path withContents++mkCreateDirectoryIfMissing :: FilePath -> BasicIO -> BasicIO+mkCreateDirectoryIfMissing path withUnit = Fixed $ CreateDirectoryIfMissing path withUnit++mkGetDirectoryContents :: FilePath -> (Async [FilePath] -> BasicIO) -> BasicIO+mkGetDirectoryContents path withEntries = Fixed $ GetDirectoryContents path withEntries++mkGetDirectoryContentsSync :: FilePath -> ([FilePath] -> BasicIO) -> BasicIO+mkGetDirectoryContentsSync path withEntries = Fixed $ GetDirectoryContentsSync path withEntries++mkForkIO :: BasicIO -> BasicIO -> BasicIO+mkForkIO bio withUnit = Fixed $ ForkIO bio withUnit++mkForkOS :: BasicIO -> BasicIO -> BasicIO+mkForkOS bio withUnit = Fixed $ ForkOS bio withUnit++mkSDLIO :: SDLIOF BasicIO -> BasicIO+mkSDLIO sdlio = Fixed $ SDLIO sdlio++mkGLIO :: GLIOF BasicIO -> BasicIO+mkGLIO glio = Fixed $ GLIO glio++-- | Microseconds thread delay, with ‘unbounded-delays’.+mkDelayUs :: Integer -> BasicIO -> BasicIO+mkDelayUs us withUnit = Fixed $ DelayUs us withUnit++mkGetUs :: (Integer -> BasicIO) -> BasicIO+mkGetUs withUs = Fixed $ GetUs withUs++-- * Utils++getUsIO :: IO Integer+getUsIO = getSystemTime >>= \(MkSystemTime secs nanosecs) -> return $ (1000000 * (fromIntegral secs)) + ((fromIntegral nanosecs) `div` 1000)
+ Immutaball/Share/ImmutaballIO/DirectoryIO.hs view
@@ -0,0 +1,192 @@+{-# 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 #-}++-- ImmutaballIO.hs.++{-# LANGUAGE Haskell2010 #-}+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, InstanceSigs, ScopedTypeVariables, ExistentialQuantification #-}++module Immutaball.Share.ImmutaballIO.DirectoryIO+	(+		-- * DirectoryIO+		DirectoryIO,+		DirectoryIOF(..),+		runDirectoryIO,++		-- * mfix+		FixDirectoryIOException(..),+		fixDirectoryIOExceptionToException,+		fixDirectoryIOExceptionFromException,+		PrematureEvaluationFixDirectoryIOException(..),+		EmptyFixDirectoryIOException(..),+		fixDirectoryIOF,+		unsafeFixDirectoryIOFTo,++		-- * Runners+		runDirectoryIOIO,++		-- * DirectoryIO aliases that apply the Fixed wrapper+		mkGetXdgDirectoryData,+		mkGetXdgDirectoryDataSync,+		mkGetXdgDirectoryConfig,+		mkGetXdgDirectoryConfigSync,+		mkGetXdgDirectoryCache,+		mkGetXdgDirectoryCacheSync,+		mkGetXdgDirectoryState,+		mkGetXdgDirectoryStateSync+	) where++import Prelude ()+import Immutaball.Prelude++import Control.Concurrent.Async+import System.Directory++import Immutaball.Share.Utils++-- (mfix imports.)+import Control.Concurrent.MVar+import Control.Exception+import Data.Typeable+import GHC.IO.Unsafe (unsafeDupableInterleaveIO)+import System.IO.Unsafe (unsafePerformIO)++-- * DirectoryIO++type DirectoryIO = Fixed DirectoryIOF+data DirectoryIOF a =+	-- | Get ~/.local/share/path .+	  GetXdgDirectoryData FilePath (Async FilePath -> a)+	| GetXdgDirectoryDataSync FilePath (FilePath -> a)+	-- | Get ~/.local/config/path .+	| GetXdgDirectoryConfig FilePath (Async FilePath -> a)+	| GetXdgDirectoryConfigSync FilePath (FilePath -> a)+	-- | Get ~/.local/cache/path .+	| GetXdgDirectoryCache FilePath (Async FilePath -> a)+	| GetXdgDirectoryCacheSync FilePath (FilePath -> a)+	-- | Get ~/.local/state/path .+	| GetXdgDirectoryState FilePath (Async FilePath -> a)+	| GetXdgDirectoryStateSync FilePath (FilePath -> a)+instance Functor DirectoryIOF where+	fmap :: (a -> b) -> (DirectoryIOF a -> DirectoryIOF b)+	fmap f (GetXdgDirectoryData       path withDir) = GetXdgDirectoryData       path (f . withDir)+	fmap f (GetXdgDirectoryDataSync   path withDir) = GetXdgDirectoryDataSync   path (f . withDir)+	fmap f (GetXdgDirectoryConfig     path withDir) = GetXdgDirectoryConfig     path (f . withDir)+	fmap f (GetXdgDirectoryConfigSync path withDir) = GetXdgDirectoryConfigSync path (f . withDir)+	fmap f (GetXdgDirectoryCache      path withDir) = GetXdgDirectoryCache      path (f . withDir)+	fmap f (GetXdgDirectoryCacheSync  path withDir) = GetXdgDirectoryCacheSync  path (f . withDir)+	fmap f (GetXdgDirectoryState      path withDir) = GetXdgDirectoryState      path (f . withDir)+	fmap f (GetXdgDirectoryStateSync  path withDir) = GetXdgDirectoryStateSync  path (f . withDir)++runDirectoryIO :: DirectoryIO -> IO ()+runDirectoryIO dio = cata runDirectoryIOIO dio++-- TODO: revisit.+{-+instance Foldable DirectoryIOF where+	foldr :: (a -> b -> b) -> b -> DirectoryIOF a -> b+	foldr _reduce reduction0 (GetXdgDirectoryData   _path) = reduction0+	foldr _reduce reduction0 (GetXdgDirectoryConfig _path) = reduction0+	foldr _reduce reduction0 (GetXdgDirectoryCache  _path) = reduction0+	foldr _reduce reduction0 (GetXdgDirectoryState  _path) = reduction0+instance Traversable DirectoryIOF where+	traverse :: Applicative f => (a -> f b) -> DirectoryIOF a -> f (DirectoryIOF b)+	traverse _traversal (GetXdgDirectoryData   path) = pure GetXdgDirectoryData   <*> pure path+	traverse _traversal (GetXdgDirectoryConfig path) = pure GetXdgDirectoryConfig <*> pure path+	traverse _traversal (GetXdgDirectoryCache  path) = pure GetXdgDirectoryCache  <*> pure path+	traverse _traversal (GetXdgDirectoryState  path) = pure GetXdgDirectoryState  <*> pure path+-}++-- * mfix++data FixDirectoryIOException = forall e. Exception e => FixDirectoryIOException e+instance Show FixDirectoryIOException where+	show (FixDirectoryIOException e) = show e+instance Exception FixDirectoryIOException+fixDirectoryIOExceptionToException :: Exception e => e -> SomeException+fixDirectoryIOExceptionToException = toException . FixDirectoryIOException+fixDirectoryIOExceptionFromException :: Exception e => SomeException -> Maybe e+fixDirectoryIOExceptionFromException x = do+	FixDirectoryIOException a <- fromException x+	cast a++data PrematureEvaluationFixDirectoryIOException = PrematureEvaluationFixDirectoryIOException+	deriving (Show)+instance Exception PrematureEvaluationFixDirectoryIOException where+	toException = fixDirectoryIOExceptionToException+	fromException = fixDirectoryIOExceptionFromException++data EmptyFixDirectoryIOException = EmptyFixDirectoryIOException+	deriving (Show)+instance Exception EmptyFixDirectoryIOException where+	toException = fixDirectoryIOExceptionToException+	fromException = fixDirectoryIOExceptionFromException++--    mfix f = mfix f >>= f+-- => mfix f = join $ f <$> mfix f+-- Incorrect: runs f twice.+	--x -> f undefined >>= mfix f+{-+fixDirectoryIOF :: (me -> DirectoryIOF me) -> DirectoryIOF me+fixDirectoryIOF f = case f (error "Error: fixDirectoryIOF: premature evaluation of result before we could start it!") of+	x -> joinDirectoryIOF $ f <$> x+-}+-- Do it like fixIO and fixST (see also their notes; it's a little tricky).+-- Use a lazily read MVar.+fixDirectoryIOF :: (me -> DirectoryIOF me) -> DirectoryIOF me+fixDirectoryIOF f = unsafePerformIO $ do+	mme <- newEmptyMVar+	return $ unsafeFixDirectoryIOFTo mme f++-- | Helper for fixDirectoryIOF.+unsafeFixDirectoryIOFTo :: MVar me -> (me -> DirectoryIOF me) -> DirectoryIOF me+unsafeFixDirectoryIOFTo mme f = unsafePerformIO $ do+	me_ <- unsafeDupableInterleaveIO (readMVar mme `catch` \BlockedIndefinitelyOnMVar -> throwIO PrematureEvaluationFixDirectoryIOException)+	case f me_ of+		_y@(GetXdgDirectoryData       path withDir) -> return $ GetXdgDirectoryData       path ((\me -> unsafePerformIO $ putMVar mme me >> return me) . withDir)+		_y@(GetXdgDirectoryDataSync   path withDir) -> return $ GetXdgDirectoryDataSync   path ((\me -> unsafePerformIO $ putMVar mme me >> return me) . withDir)+		_y@(GetXdgDirectoryConfig     path withDir) -> return $ GetXdgDirectoryConfig     path ((\me -> unsafePerformIO $ putMVar mme me >> return me) . withDir)+		_y@(GetXdgDirectoryConfigSync path withDir) -> return $ GetXdgDirectoryConfigSync path ((\me -> unsafePerformIO $ putMVar mme me >> return me) . withDir)+		_y@(GetXdgDirectoryCache      path withDir) -> return $ GetXdgDirectoryCache      path ((\me -> unsafePerformIO $ putMVar mme me >> return me) . withDir)+		_y@(GetXdgDirectoryCacheSync  path withDir) -> return $ GetXdgDirectoryCacheSync  path ((\me -> unsafePerformIO $ putMVar mme me >> return me) . withDir)+		_y@(GetXdgDirectoryState      path withDir) -> return $ GetXdgDirectoryState      path ((\me -> unsafePerformIO $ putMVar mme me >> return me) . withDir)+		_y@(GetXdgDirectoryStateSync  path withDir) -> return $ GetXdgDirectoryStateSync  path ((\me -> unsafePerformIO $ putMVar mme me >> return me) . withDir)++-- * Runners++runDirectoryIOIO :: DirectoryIOF (IO ()) -> IO ()+runDirectoryIOIO (GetXdgDirectoryData       path withDir) = withAsync (getXdgDirectory XdgData   path) (withDir)+runDirectoryIOIO (GetXdgDirectoryDataSync   path withDir) = getXdgDirectory XdgData   path >>= withDir+runDirectoryIOIO (GetXdgDirectoryConfig     path withDir) = withAsync (getXdgDirectory XdgConfig path) (withDir)+runDirectoryIOIO (GetXdgDirectoryConfigSync path withDir) = getXdgDirectory XdgConfig path >>= withDir+runDirectoryIOIO (GetXdgDirectoryCache      path withDir) = withAsync (getXdgDirectory XdgCache  path) (withDir)+runDirectoryIOIO (GetXdgDirectoryCacheSync  path withDir) = getXdgDirectory XdgCache  path >>= withDir+runDirectoryIOIO (GetXdgDirectoryState      path withDir) = withAsync (getXdgDirectory XdgState  path) (withDir)+runDirectoryIOIO (GetXdgDirectoryStateSync  path withDir) = getXdgDirectory XdgState  path >>= withDir++-- * DirectoryIO aliases that apply the Fixed wrapper++mkGetXdgDirectoryData :: FilePath -> (Async FilePath -> DirectoryIO) -> DirectoryIO+mkGetXdgDirectoryData path withDir = Fixed $ GetXdgDirectoryData path withDir++mkGetXdgDirectoryDataSync :: FilePath -> (FilePath -> DirectoryIO) -> DirectoryIO+mkGetXdgDirectoryDataSync path withDir = Fixed $ GetXdgDirectoryDataSync path withDir++mkGetXdgDirectoryConfig :: FilePath -> (Async FilePath -> DirectoryIO) -> DirectoryIO+mkGetXdgDirectoryConfig path withDir = Fixed $ GetXdgDirectoryConfig path withDir++mkGetXdgDirectoryConfigSync :: FilePath -> (FilePath -> DirectoryIO) -> DirectoryIO+mkGetXdgDirectoryConfigSync path withDir = Fixed $ GetXdgDirectoryConfigSync path withDir++mkGetXdgDirectoryCache :: FilePath -> (Async FilePath -> DirectoryIO) -> DirectoryIO+mkGetXdgDirectoryCache path withDir = Fixed $ GetXdgDirectoryCache path withDir++mkGetXdgDirectoryCacheSync :: FilePath -> (FilePath -> DirectoryIO) -> DirectoryIO+mkGetXdgDirectoryCacheSync path withDir = Fixed $ GetXdgDirectoryCacheSync path withDir++mkGetXdgDirectoryState :: FilePath -> (Async FilePath -> DirectoryIO) -> DirectoryIO+mkGetXdgDirectoryState path withDir = Fixed $ GetXdgDirectoryState path withDir++mkGetXdgDirectoryStateSync :: FilePath -> (FilePath -> DirectoryIO) -> DirectoryIO+mkGetXdgDirectoryStateSync path withDir = Fixed $ GetXdgDirectoryStateSync path withDir
+ Immutaball/Share/ImmutaballIO/GLIO.hs view
@@ -0,0 +1,1575 @@+{-# 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 #-}++-- ImmutaballIO.hs.++{-# LANGUAGE Haskell2010 #-}+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, InstanceSigs, ScopedTypeVariables, ExistentialQuantification #-}++module Immutaball.Share.ImmutaballIO.GLIO+	(+		-- * GLIO+		GLIO,+		GLIOF(..),+		runGLIO,++		-- * mfix+		FixGLIOException(..),+		fixGLIOExceptionToException,+		fixGLIOExceptionFromException,+		PrematureEvaluationFixGLIOException(..),+		EmptyFixGLIOException(..),+		fixGLIOF,+		unsafeFixGLIOFTo,++		-- * Runners+		runGLIOIO,+		hglClearColor,+		hglTexImage2D,+		hglGenTextures,+		hglDeleteTextures,+		hglTexEnvfv,+		hglTexEnviv,+		hglTexParameterfv,+		hglTexParameteriv,+		hglTexParameterIiv,+		hglTexParameterIuiv,+		hglTextureParameterfv,+		hglTextureParameteriv,+		hglTextureParameterIiv,+		hglTextureParameterIuiv,+		hglShaderSource,+		hglGenProgramPipelines,+		hglDeleteProgramPipelines,+		hglGetMaxVertexTextureImageUnits,+		hglGetShaderiv,+		hglGetProgramiv,+		hglGetShaderInfoLog,+		hglGetProgramInfoLog,+		hglGetlUniformfv,+		hglGetlUniformiv,+		hglGetlUniformuiv,+		hglGetlUniformdv,+		hglGenBuffers,+		hglDeleteBuffers,+		hglNamedBufferData,+		hglNamedBufferSubData,+		hglBufferData,+		hglBufferSubData,+		hglGenVertexArrays,+		hglDeleteVertexArrays,+		hglVertexAttribPointer,+		hglVertexAttribIPointer,+		hglVertexAttribLPointer,+		--hglDrawElements,+		--hglDrawElementsData,+		hglDrawElementsRaw,+		hglGetString,+		hglGetStringi,++		-- * GLIO aliases that apply the Fixed wrapper+		mkEmptyGLIO,+		mkPureGLIO,+		mkUnfixGLIO,+		mkJoinGLIO,+		mkGLClear,+		mkGLClearColor,+		mkGLTexImage2D,+		mkGLGenTextures,+		mkGLBindTexture,+		mkGLDeleteTextures,+		mkGLGetError,+		mkGLColor4d,+		mkGLBegin,+		mkGLVertex2d,+		mkGLEnd,+		mkGLActiveTexture,+		mkGLClientActiveTexture,+		mkGLEnable,+		mkGLDisable,+		mkGLEnablei,+		mkGLDisablei,+		mkGLTexCoord2d,+		mkGLTexEnvf,+		mkGLTexEnvi,+		mkGLTexEnvfv,+		mkGLTexEnviv,+		mkGLTexParameterf,+		mkGLTexParameteri,+		mkGLTextureParameterf,+		mkGLTextureParameteri,+		mkGLTexParameterfv,+		mkGLTexParameteriv,+		mkGLTexParameterIiv,+		mkGLTexParameterIuiv,+		mkGLTextureParameterfv,+		mkGLTextureParameteriv,+		mkGLTextureParameterIiv,+		mkGLTextureParameterIuiv,+		mkGLDepthMask,+		mkGLDepthFunc,+		mkGLBlendEquationSeparate,+		mkGLBlendEquationSeparatei,+		mkGLBlendFuncSeparate,+		mkGLBlendFuncSeparatei,+		mkGLCreateProgram,+		mkGLDeleteProgram,+		mkGLCreateShader,+		mkGLDeleteShader,+		mkGLShaderSource,+		mkGLCompileShader,+		mkGLAttachShader,+		mkGLDetachShader,+		mkGLLinkProgram,+		mkGLUseProgram,+		mkGLProgramParameteri,+		mkGLBindProgramPipeline,+		mkGLUseProgramStages,+		mkGLGenProgramPipelines,+		mkGLDeleteProgramPipelines,+		mkGLGenerateMipmap,+		mkGLGenerateTextureMipmap,+		mkGLGetMaxVertexTextureImageUnits,+		mkGLGetShaderiv,+		mkGLGetProgramiv,+		mkGLGetShaderInfoLog,+		mkGLGetProgramInfoLog,+		mkGLUniform1f,+		mkGLUniform2f,+		mkGLUniform3f,+		mkGLUniform4f,+		mkGLUniform1i,+		mkGLUniform2i,+		mkGLUniform3i,+		mkGLUniform4i,+		mkGLUniform1ui,+		mkGLUniform2ui,+		mkGLUniform3ui,+		mkGLUniform4ui,+		mkGLGetlUniformfv,+		mkGLGetlUniformiv,+		mkGLGetlUniformuiv,+		mkGLGetlUniformdv,+		mkGLGenBuffers,+		mkGLDeleteBuffers,+		mkGLNamedBufferData,+		mkGLNamedBufferSubData,+		mkGLBufferData,+		mkGLBufferSubData,+		mkGLGenVertexArrays,+		mkGLDeleteVertexArrays,+		mkGLBindBuffer,+		mkGLBindBufferBase,+		mkGLBindBufferRange,+		mkGLBindVertexArray,+		mkGLVertexAttribPointer,+		mkGLVertexAttribIPointer,+		mkGLVertexAttribLPointer,+		mkGLEnableVertexArrayAttrib,+		mkGLDisableVertexArrayAttrib,+		mkGLEnableVertexAttribArray,+		mkGLDisableVertexAttribArray,+		--mkGLDrawElements,+		--mkGLDrawElementsData,+		mkGLDrawElementsRaw,+		mkGLDrawArrays,+		mkGLGetString,+		mkGLGetStringi,+		mkGLDepthRange,+		mkGLOrtho,+		mkGLCullFace,++		-- * types+		GLData,+		glDataToBS,+		glDataToBL,+		bsToGLData,+		blToGLData+	) where++import Prelude ()+import Immutaball.Prelude++import Control.Monad.Fix+import Data.List+import Data.Word+import Foreign.C.Types+import Foreign.Ptr+import Foreign.Storable (sizeOf)++import Graphics.GL.Compatibility45+--import Graphics.GL.Core45+import Graphics.GL.Types+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BL+import Data.Array.Base+import Data.Array.Storable.Safe++import Immutaball.Share.Utils++-- (mfix imports.)+import Control.Concurrent.MVar+import Control.Exception+import Data.Typeable+import GHC.IO.Unsafe (unsafeDupableInterleaveIO)+import System.IO.Unsafe (unsafePerformIO)++-- * GLIO++type GLIO = Fixed GLIOF+data GLIOF me =+	  EmptyGLIOF+	| PureGLIOF me+	| UnfixGLIOF (GLIOF me)+	| JoinGLIOF (GLIOF (GLIOF me))++	| GLClear GLbitfield me+	| GLClearColor GLdouble GLdouble GLdouble GLdouble me++	-- | Set a texture.+	| GLTexImage2D GLenum GLint GLint GLsizei GLsizei GLint GLenum GLenum GLData me+	-- | Create a texture.+	| GLGenTextures GLsizei ([GLuint] -> me)+	-- | Set OpenGL current texture.+	| GLBindTexture GLenum GLuint me+	-- | Delete a texture.+	| GLDeleteTextures [GLuint] me+	| GLGetError (GLenum -> me)++	| GLColor4d GLdouble GLdouble GLdouble GLdouble me+	| GLBegin GLenum me+	| GLVertex2d GLdouble GLdouble me+	| GLEnd me+	| GLActiveTexture GLenum me+	| GLClientActiveTexture GLenum me+	| GLEnable GLenum me+	| GLDisable GLenum me+	| GLEnablei GLenum GLuint me+	| GLDisablei GLenum GLuint me+	| GLTexCoord2d GLdouble GLdouble me+	| GLTexEnvf GLenum GLenum GLfloat me+	| GLTexEnvi GLenum GLenum GLint me+	| GLTexEnvfv GLenum GLenum [GLfloat] me+	| GLTexEnviv GLenum GLenum [GLint] me+	| GLTexParameterf GLenum GLenum GLfloat me+	| GLTexParameteri GLenum GLenum GLint me+	| GLTextureParameterf GLenum GLenum GLfloat me+	| GLTextureParameteri GLenum GLenum GLint me+	| GLTexParameterfv GLenum GLenum [GLfloat] me+	| GLTexParameteriv GLenum GLenum [GLint] me+	| GLTexParameterIiv GLenum GLenum [GLint] me+	| GLTexParameterIuiv GLenum GLenum [GLuint] me+	| GLTextureParameterfv GLenum GLenum [GLfloat] me+	| GLTextureParameteriv GLenum GLenum [GLint] me+	| GLTextureParameterIiv GLenum GLenum [GLint] me+	| GLTextureParameterIuiv GLenum GLenum [GLuint] me++	| GLDepthMask GLboolean me+	| GLDepthFunc GLenum me++	| GLBlendEquationSeparate GLenum GLenum me+	| GLBlendEquationSeparatei GLuint GLenum GLenum me+	| GLBlendFuncSeparate GLenum GLenum GLenum GLenum me+	| GLBlendFuncSeparatei GLuint GLenum GLenum GLenum GLenum me++	| GLCreateProgram (GLuint -> me)+	| GLDeleteProgram GLuint me+	| GLCreateShader GLenum (GLuint -> me)+	| GLDeleteShader GLuint me++	| GLShaderSource GLuint [String] me+	| GLCompileShader GLuint me+	| GLAttachShader GLuint GLuint me+	| GLDetachShader GLuint GLuint me+	| GLLinkProgram GLuint me+	| GLUseProgram GLuint me+	| GLProgramParameteri GLuint GLenum GLint me+	| GLBindProgramPipeline GLuint me++	| GLUseProgramStages GLuint GLbitfield GLuint me+	| GLGenProgramPipelines GLsizei ([GLuint] -> me)+	| GLDeleteProgramPipelines [GLuint] me++	| GLGenerateMipmap GLenum me+	| GLGenerateTextureMipmap GLuint me++	-- GL_Get is polymorphic in its output size, so since we lack dependent+	-- types, we'll just provide specific specializations of glGet.+	| GLGetMaxVertexTextureImageUnits (GLint64 -> me)++	| GLGetShaderiv       GLuint GLenum (GLint  -> me)+	| GLGetProgramiv      GLuint GLenum (GLint  -> me)+	| GLGetShaderInfoLog  GLuint        (String -> me)+	| GLGetProgramInfoLog GLuint        (String -> me)++	| GLUniform1f  GLint GLfloat                                me+	| GLUniform2f  GLint GLfloat GLfloat                        me+	| GLUniform3f  GLint GLfloat GLfloat GLfloat                me+	| GLUniform4f  GLint GLfloat GLfloat GLfloat GLfloat        me+	| GLUniform1i  GLint GLint                                  me+	| GLUniform2i  GLint GLint   GLint                          me+	| GLUniform3i  GLint GLint   GLint   GLint                  me+	| GLUniform4i  GLint GLint   GLint   GLint   GLint          me+	| GLUniform1ui GLint GLuint                                 me+	| GLUniform2ui GLint GLuint  GLuint                         me+	| GLUniform3ui GLint GLuint  GLuint  GLuint                 me+	| GLUniform4ui GLint GLuint  GLuint  GLuint  GLuint         me++	| GLGetlUniformfv  GLuint GLint Integer ([GLfloat]  -> me)+	| GLGetlUniformiv  GLuint GLint Integer ([GLint]    -> me)+	| GLGetlUniformuiv GLuint GLint Integer ([GLuint]   -> me)+	| GLGetlUniformdv  GLuint GLint Integer ([GLdouble] -> me)++	| GLGenBuffers    GLsizei  ([GLuint] -> me)+	| GLDeleteBuffers [GLuint] me++	| GLNamedBufferData    GLuint         GLData GLenum me+	| GLNamedBufferSubData GLuint Integer GLData        me+	| GLBufferData         GLenum         GLData GLenum me+	| GLBufferSubData      GLenum Integer GLData        me++	| GLGenVertexArrays    GLsizei  ([GLuint] -> me)+	| GLDeleteVertexArrays [GLuint] me++	| GLBindBuffer      GLenum        GLuint                     me+	| GLBindBufferBase  GLenum GLuint GLuint                     me+	| GLBindBufferRange GLenum GLuint GLuint GLintptr GLsizeiptr me++	| GLBindVertexArray GLuint me++	| GLVertexAttribPointer  GLuint GLint GLenum GLboolean GLsizei Integer me+	| GLVertexAttribIPointer GLuint GLint GLenum           GLsizei Integer me+	| GLVertexAttribLPointer GLuint GLint GLenum           GLsizei Integer me++	| GLEnableVertexArrayAttrib  GLuint GLuint me+	| GLDisableVertexArrayAttrib GLuint GLuint me+	| GLEnableVertexAttribArray         GLuint me+	| GLDisableVertexAttribArray        GLuint me++	-- Oops, data is an offset, not an actual pointer.  Disable.+	-- | GLDrawElements     GLenum [GLuint]              me+	-- Oops, data is an offset, not an actual pointer.  Disable.+	-- | GLDrawElementsData GLenum GLsizei GLenum GLData me+	| GLDrawElementsRaw GLenum GLsizei GLenum  Integer me+	| GLDrawArrays      GLenum GLint   GLsizei         me++	| GLGetString  GLenum        (BS.ByteString -> me)+	| GLGetStringi GLenum GLuint (BS.ByteString -> me)++	| GLDepthRange GLdouble GLdouble me+	| GLOrtho GLdouble GLdouble GLdouble GLdouble GLdouble GLdouble me++	| GLCullFace GLenum me++instance Functor GLIOF where+	fmap :: (a -> b) -> (GLIOF a -> GLIOF b)++	fmap _f   (EmptyGLIOF)      = EmptyGLIOF+	fmap  f   (PureGLIOF a)     = PureGLIOF (f a)+	fmap  f   (UnfixGLIOF glio) = UnfixGLIOF (f <$> glio)+	fmap  f   (JoinGLIOF glio)  = JoinGLIOF (fmap f <$> glio)++	fmap f (GLClear      mask_2               withUnit) = GLClear      mask_2               (f withUnit)+	fmap f (GLClearColor red green blue alpha withUnit) = GLClearColor red green blue alpha (f withUnit)++	fmap f (GLTexImage2D     target level internalformat width height border format type_ data_ withUnit) = GLTexImage2D target level internalformat width height border format type_ data_ (f withUnit)+	fmap f (GLGenTextures    numNames       withNames) = GLGenTextures    numNames       (f . withNames)+	fmap f (GLBindTexture    target texture withUnit)  = GLBindTexture    target texture (f withUnit)+	fmap f (GLDeleteTextures textures       withUnit)  = GLDeleteTextures textures       (f withUnit)+	fmap f (GLGetError                      withError) = GLGetError                      (f . withError)++	fmap f (GLColor4d  red green blue alpha                 withUnit) = GLColor4d  red green blue alpha                 (f withUnit)+	fmap f (GLBegin    mode                                 withUnit) = GLBegin    mode                                 (f withUnit)+	fmap f (GLVertex2d x y                                  withUnit) = GLVertex2d x y                                  (f withUnit)+	fmap f (GLEnd                                           withUnit) = GLEnd                                           (f withUnit)+	fmap f (GLActiveTexture texture                         withUnit) = GLActiveTexture texture                         (f withUnit)+	fmap f (GLClientActiveTexture texture                   withUnit) = GLClientActiveTexture texture                   (f withUnit)+	fmap f (GLEnable cap                                    withUnit) = GLEnable cap                                    (f withUnit)+	fmap f (GLDisable cap                                   withUnit) = GLDisable cap                                   (f withUnit)+	fmap f (GLEnablei cap index_                            withUnit) = GLEnablei cap index_                            (f withUnit)+	fmap f (GLDisablei cap index_                           withUnit) = GLDisablei cap index_                           (f withUnit)+	fmap f (GLTexCoord2d s t                                withUnit) = GLTexCoord2d s t                                (f withUnit)+	fmap f (GLTexEnvf target pname param                    withUnit) = GLTexEnvf target pname param                    (f withUnit)+	fmap f (GLTexEnvi target pname param                    withUnit) = GLTexEnvi target pname param                    (f withUnit)+	fmap f (GLTexEnvfv target pname params                  withUnit) = GLTexEnvfv target pname params                  (f withUnit)+	fmap f (GLTexEnviv target pname params                  withUnit) = GLTexEnviv target pname params                  (f withUnit)+	fmap f (GLTexParameterf target pname param              withUnit) = GLTexParameterf target pname param              (f withUnit)+	fmap f (GLTexParameteri target pname param              withUnit) = GLTexParameteri target pname param              (f withUnit)+	fmap f (GLTextureParameterf texture pname param         withUnit) = GLTextureParameterf texture pname param         (f withUnit)+	fmap f (GLTextureParameteri texture pname param         withUnit) = GLTextureParameteri texture pname param         (f withUnit)+	fmap f (GLTexParameterfv target pname params            withUnit) = GLTexParameterfv target pname params            (f withUnit)+	fmap f (GLTexParameteriv target pname params            withUnit) = GLTexParameteriv target pname params            (f withUnit)+	fmap f (GLTexParameterIiv target pname params           withUnit) = GLTexParameterIiv target pname params           (f withUnit)+	fmap f (GLTexParameterIuiv target pname params          withUnit) = GLTexParameterIuiv target pname params          (f withUnit)+	fmap f (GLTextureParameterfv texture pname params       withUnit) = GLTextureParameterfv texture pname params       (f withUnit)+	fmap f (GLTextureParameteriv texture pname params       withUnit) = GLTextureParameteriv texture pname params       (f withUnit)+	fmap f (GLTextureParameterIiv texture pname params      withUnit) = GLTextureParameterIiv texture pname params      (f withUnit)+	fmap f (GLTextureParameterIuiv texture pname params     withUnit) = GLTextureParameterIuiv texture pname params     (f withUnit)++	fmap f (GLDepthMask flag   withUnit) = GLDepthMask flag   (f withUnit)+	fmap f (GLDepthFunc mask_2 withUnit) = GLDepthFunc mask_2 (f withUnit)++	fmap f (GLBlendEquationSeparate modeRGB modeAlpha                withUnit) = GLBlendEquationSeparate modeRGB modeAlpha                (f withUnit)+	fmap f (GLBlendEquationSeparatei buf modeRGB modeAlpha           withUnit) = GLBlendEquationSeparatei buf modeRGB modeAlpha           (f withUnit)+	fmap f (GLBlendFuncSeparate srcRGB dstRGB srcAlpha dstAlpha      withUnit) = GLBlendFuncSeparate srcRGB dstRGB srcAlpha dstAlpha      (f withUnit)+	fmap f (GLBlendFuncSeparatei buf srcRGB dstRGB srcAlpha dstAlpha withUnit) = GLBlendFuncSeparatei buf srcRGB dstRGB srcAlpha dstAlpha (f withUnit)++	fmap f (GLCreateProgram withId)           = GLCreateProgram           (f . withId)+	fmap f (GLDeleteProgram id_ withUnit)     = GLDeleteProgram id_       (f withUnit)+	fmap f (GLCreateShader shaderType withId) = GLCreateShader shaderType (f . withId)+	fmap f (GLDeleteShader id_ withUnit)      = GLDeleteShader id_        (f withUnit)++	fmap f (GLShaderSource shader strings           withUnit) = GLShaderSource shader strings           (f withUnit)+	fmap f (GLCompileShader id_                     withUnit) = GLCompileShader id_                     (f withUnit)+	fmap f (GLAttachShader program shader           withUnit) = GLAttachShader program shader           (f withUnit)+	fmap f (GLDetachShader program shader           withUnit) = GLDetachShader program shader           (f withUnit)+	fmap f (GLLinkProgram program                   withUnit) = GLLinkProgram program                   (f withUnit)+	fmap f (GLUseProgram id_                        withUnit) = GLUseProgram id_                        (f withUnit)+	fmap f (GLProgramParameteri program pname value withUnit) = GLProgramParameteri program pname value (f withUnit)+	fmap f (GLBindProgramPipeline id_               withUnit) = GLBindProgramPipeline id_               (f withUnit)++	fmap f (GLUseProgramStages pipeline stages program withUnit)  = GLUseProgramStages pipeline stages program (f withUnit)+	fmap f (GLGenProgramPipelines    numNames          withNames) = GLGenProgramPipelines    numNames             (f . withNames)+	fmap f (GLDeleteProgramPipelines pipelines         withUnit)  = GLDeleteProgramPipelines pipelines            (f withUnit)++	fmap f (GLGenerateMipmap        target  withUnit) = GLGenerateMipmap        target  (f withUnit)+	fmap f (GLGenerateTextureMipmap texture withUnit) = GLGenerateTextureMipmap texture (f withUnit)++	fmap f (GLGetMaxVertexTextureImageUnits withNum) = GLGetMaxVertexTextureImageUnits (f . withNum)++	fmap f (GLGetShaderiv       shader  pname withOut) = GLGetShaderiv       shader  pname (f . withOut)+	fmap f (GLGetProgramiv      program pname withOut) = GLGetProgramiv      program pname (f . withOut)+	fmap f (GLGetShaderInfoLog  shader        withLog) = GLGetShaderInfoLog  shader        (f . withLog)+	fmap f (GLGetProgramInfoLog program       withLog) = GLGetProgramInfoLog program       (f . withLog)++	fmap f (GLUniform1f  location v0          withUnit) = GLUniform1f  location v0          (f withUnit)+	fmap f (GLUniform2f  location v0 v1       withUnit) = GLUniform2f  location v0 v1       (f withUnit)+	fmap f (GLUniform3f  location v0 v1 v2    withUnit) = GLUniform3f  location v0 v1 v2    (f withUnit)+	fmap f (GLUniform4f  location v0 v1 v2 v3 withUnit) = GLUniform4f  location v0 v1 v2 v3 (f withUnit)+	fmap f (GLUniform1i  location v0          withUnit) = GLUniform1i  location v0          (f withUnit)+	fmap f (GLUniform2i  location v0 v1       withUnit) = GLUniform2i  location v0 v1       (f withUnit)+	fmap f (GLUniform3i  location v0 v1 v2    withUnit) = GLUniform3i  location v0 v1 v2    (f withUnit)+	fmap f (GLUniform4i  location v0 v1 v2 v3 withUnit) = GLUniform4i  location v0 v1 v2 v3 (f withUnit)+	fmap f (GLUniform1ui location v0          withUnit) = GLUniform1ui location v0          (f withUnit)+	fmap f (GLUniform2ui location v0 v1       withUnit) = GLUniform2ui location v0 v1       (f withUnit)+	fmap f (GLUniform3ui location v0 v1 v2    withUnit) = GLUniform3ui location v0 v1 v2    (f withUnit)+	fmap f (GLUniform4ui location v0 v1 v2 v3 withUnit) = GLUniform4ui location v0 v1 v2 v3 (f withUnit)++	fmap f (GLGetlUniformfv  program location len withOuts) = GLGetlUniformfv  program location len (f . withOuts)+	fmap f (GLGetlUniformiv  program location len withOuts) = GLGetlUniformiv  program location len (f . withOuts)+	fmap f (GLGetlUniformuiv program location len withOuts) = GLGetlUniformuiv program location len (f . withOuts)+	fmap f (GLGetlUniformdv  program location len withOuts) = GLGetlUniformdv  program location len (f . withOuts)++	fmap f (GLGenBuffers    num   withNames) = GLGenBuffers    num   (f . withNames)+	fmap f (GLDeleteBuffers names withUnit)  = GLDeleteBuffers names (f withUnit)++	fmap f (GLNamedBufferData    buffer        data_ usage withUnit) = GLNamedBufferData    buffer        data_ usage (f withUnit)+	fmap f (GLNamedBufferSubData buffer offset data_       withUnit) = GLNamedBufferSubData buffer offset data_       (f withUnit)+	fmap f (GLBufferData         target        data_ usage withUnit) = GLBufferData         target        data_ usage (f withUnit)+	fmap f (GLBufferSubData      target offset data_       withUnit) = GLBufferSubData      target offset data_       (f withUnit)++	fmap f (GLGenVertexArrays    num   withNames) = GLGenVertexArrays    num   (f . withNames)+	fmap f (GLDeleteVertexArrays names withUnit)  = GLDeleteVertexArrays names (f withUnit)++	fmap f (GLBindBuffer      target        buffer             withUnit) = GLBindBuffer      target        buffer             (f withUnit)+	fmap f (GLBindBufferBase  target index_ buffer             withUnit) = GLBindBufferBase  target index_ buffer             (f withUnit)+	fmap f (GLBindBufferRange target index_ buffer offset size withUnit) = GLBindBufferRange target index_ buffer offset size (f withUnit)++	fmap f (GLBindVertexArray array_ withUnit) = GLBindVertexArray array_ (f withUnit)++	fmap f (GLVertexAttribPointer  index_ size type_ normalized stride offset withUnit) = GLVertexAttribPointer  index_ size type_ normalized stride offset (f withUnit)+	fmap f (GLVertexAttribIPointer index_ size type_            stride offset withUnit) = GLVertexAttribIPointer index_ size type_            stride offset (f withUnit)+	fmap f (GLVertexAttribLPointer index_ size type_            stride offset withUnit) = GLVertexAttribLPointer index_ size type_            stride offset (f withUnit)++	fmap f (GLEnableVertexArrayAttrib  vaobj index_ withUnit) = GLEnableVertexArrayAttrib  vaobj index_ (f withUnit)+	fmap f (GLDisableVertexArrayAttrib vaobj index_ withUnit) = GLDisableVertexArrayAttrib vaobj index_ (f withUnit)+	fmap f (GLEnableVertexAttribArray        index_ withUnit) = GLEnableVertexAttribArray        index_ (f withUnit)+	fmap f (GLDisableVertexAttribArray       index_ withUnit) = GLDisableVertexAttribArray       index_ (f withUnit)++	--fmap f (GLDrawElements     mode             indices_ withUnit) = GLDrawElements     mode             indices_ (f withUnit)+	--fmap f (GLDrawElementsData mode count type_ indices_ withUnit) = GLDrawElementsData mode count type_ indices_ (f withUnit)+	fmap f (GLDrawElementsRaw mode count type_ offset withUnit) = GLDrawElementsRaw mode count type_ offset (f withUnit)+	fmap f (GLDrawArrays      mode first count        withUnit) = GLDrawArrays      mode first count        (f withUnit)++	fmap f (GLGetString  name        withString) = GLGetString  name        (f . withString)+	fmap f (GLGetStringi name index_ withString) = GLGetStringi name index_ (f . withString)++	fmap f (GLDepthRange                       nearVal farVal withUnit) = GLDepthRange                       nearVal farVal (f withUnit)+	fmap f (GLOrtho      left right bottom top nearVal farVal withUnit) = GLOrtho      left right bottom top nearVal farVal (f withUnit)++	fmap f (GLCullFace mode withUnit) = GLCullFace mode (f withUnit)++runGLIO :: GLIO -> IO ()+runGLIO glio = cata runGLIOIO glio++-- TODO: revisit:+{-+instance Foldable SDLIOF where+	foldr :: (a -> b -> b) -> b -> SDLIOF a -> b+	foldr reduce reduction0 (SDLWithInit _subsystems sdlio) = reduce sdlio reduction0+instance Traversable SDLIOF where+	traverse :: Applicative f => (a -> f b) -> SDLIOF a -> f (SDLIOF b)+	traverse traversal (SDLWithInit subsystems sdlio) = pure SDLWithInit <*> pure subsystems <*> traversal sdlio+-}+++-- * mfix++data FixGLIOException = forall e. Exception e => FixGLIOException e+instance Show FixGLIOException where+	show (FixGLIOException e) = show e+instance Exception FixGLIOException+fixGLIOExceptionToException :: Exception e => e -> SomeException+fixGLIOExceptionToException = toException . FixGLIOException+fixGLIOExceptionFromException :: Exception e => SomeException -> Maybe e+fixGLIOExceptionFromException x = do+	FixGLIOException a <- fromException x+	cast a++data PrematureEvaluationFixGLIOException = PrematureEvaluationFixGLIOException+	deriving (Show)+instance Exception PrematureEvaluationFixGLIOException where+	toException = fixGLIOExceptionToException+	fromException = fixGLIOExceptionFromException++data EmptyFixGLIOException = EmptyFixGLIOException+	deriving (Show)+instance Exception EmptyFixGLIOException where+	toException = fixGLIOExceptionToException+	fromException = fixGLIOExceptionFromException++--    mfix f = mfix f >>= f+-- => mfix f = join $ f <$> mfix f+-- Incorrect: runs f twice.+	--x -> f undefined >>= mfix f+{-+fixGLIOF :: (me -> GLIOF me) -> GLIOF me+fixGLIOF f = case f (error "Error: fixGLIOF: premature evaluation of result before we could start it!") of+	x -> joinGLIOF $ f <$> x+-}+-- Do it like fixIO and fixST (see also their notes; it's a little tricky).+-- Use a lazily read MVar.+fixGLIOF :: (me -> GLIOF me) -> GLIOF me+fixGLIOF f = unsafePerformIO $ do+	mme <- newEmptyMVar+	return $ unsafeFixGLIOFTo mme f++-- | Helper for fixGLIOF.+unsafeFixGLIOFTo :: MVar me -> (me -> GLIOF me) -> GLIOF me+unsafeFixGLIOFTo mme f = unsafePerformIO $ do+	me_ <- unsafeDupableInterleaveIO (readMVar mme `catch` \BlockedIndefinitelyOnMVar -> throwIO PrematureEvaluationFixGLIOException)+	case f me_ of+		--_y@(EmptyGLIOF)        -> throwIO EmptyFixGLIOException+		_y@(EmptyGLIOF)        -> return $ EmptyGLIOF+		y@(PureGLIOF a)        -> putMVar mme a >> return y+		_y@(UnfixGLIOF glio)   -> return . UnfixGLIOF . unsafeFixGLIOFTo mme $ const glio+		-- Join: Cover all multi-branching (or else we could hang on multiple putMVars), then just fmap for all other cases.+		-- (No branching GLIOFs currently.  So proceed to the final JoinGLIOF case.)+		_y@(JoinGLIOF glio)    -> return $ JoinGLIOF (unsafeFixGLIOFTo mme . const <$> glio)++		y@( GLClear      _mask                    me) -> putMVar mme me >> return y+		y@( GLClearColor _red _green _blue _alpha me) -> putMVar mme me >> return y++		y@( GLTexImage2D     _target _level _internalformat _width _height _border _format _type _data me) -> putMVar mme me >> return y+		_y@(GLGenTextures    numNames         withNames) -> return $ GLGenTextures numNames ((\me -> unsafePerformIO $ putMVar mme me >> return me) . withNames)+		y@( GLBindTexture    _target _texture me)        -> putMVar mme me >> return y+		y@( GLDeleteTextures _textures        me)        -> putMVar mme me >> return y+		_y@(GLGetError                        withError) -> return $ GLGetError             ((\me -> unsafePerformIO $ putMVar mme me >> return me) . withError)++		y@( GLColor4d  _red _green _blue _alpha            me) -> putMVar mme me >> return y+		y@( GLBegin    _mode                               me) -> putMVar mme me >> return y+		y@( GLVertex2d _ _                                 me) -> putMVar mme me >> return y+		y@( GLEnd                                          me) -> putMVar mme me >> return y+		y@( GLActiveTexture _texture                       me) -> putMVar mme me >> return y+		y@( GLClientActiveTexture _texture                 me) -> putMVar mme me >> return y+		y@( GLEnable _cap                                  me) -> putMVar mme me >> return y+		y@( GLDisable _cap                                 me) -> putMVar mme me >> return y+		y@( GLEnablei _cap _index                          me) -> putMVar mme me >> return y+		y@( GLDisablei _cap _index                         me) -> putMVar mme me >> return y+		y@( GLTexCoord2d _s _t                             me) -> putMVar mme me >> return y+		y@( GLTexEnvf _target _pname _param                me) -> putMVar mme me >> return y+		y@( GLTexEnvi _target _pname _param                me) -> putMVar mme me >> return y+		y@( GLTexEnvfv _target _pname _params              me) -> putMVar mme me >> return y+		y@( GLTexEnviv _target _pname _params              me) -> putMVar mme me >> return y+		y@( GLTexParameterf _target _pname _param          me) -> putMVar mme me >> return y+		y@( GLTexParameteri _target _pname _param          me) -> putMVar mme me >> return y+		y@( GLTextureParameterf _texture _pname _param     me) -> putMVar mme me >> return y+		y@( GLTextureParameteri _texture _pname _param     me) -> putMVar mme me >> return y+		y@( GLTexParameterfv _target _pname _params        me) -> putMVar mme me >> return y+		y@( GLTexParameteriv _target _pname _params        me) -> putMVar mme me >> return y+		y@( GLTexParameterIiv _target _pname _params       me) -> putMVar mme me >> return y+		y@( GLTexParameterIuiv _target _pname _params      me) -> putMVar mme me >> return y+		y@( GLTextureParameterfv _texture _pname _params   me) -> putMVar mme me >> return y+		y@( GLTextureParameteriv _texture _pname _params   me) -> putMVar mme me >> return y+		y@( GLTextureParameterIiv _texture _pname _params  me) -> putMVar mme me >> return y+		y@( GLTextureParameterIuiv _texture _pname _params me) -> putMVar mme me >> return y++		y@( GLDepthMask _flag me) -> putMVar mme me >> return y+		y@( GLDepthFunc _func me) -> putMVar mme me >> return y++		y@( GLBlendEquationSeparate _modeRGB _modeAlpha me)       -> putMVar mme me >> return y+		y@( GLBlendEquationSeparatei _buf _modeRGB _modeAlpha me) -> putMVar mme me >> return y++		y@( GLBlendFuncSeparate _srcRGB _dstRGB _srcAlpha _dstAlpha me)       -> putMVar mme me >> return y+		y@( GLBlendFuncSeparatei _buf _srcRGB _dstRGB _srcAlpha _dstAlpha me) -> putMVar mme me >> return y++		_y@(GLCreateProgram           withId) -> return $ GLCreateProgram           ((\me -> unsafePerformIO $ putMVar mme me >> return me) . withId)+		y@( GLDeleteProgram _id       me)     -> putMVar mme me >> return y+		_y@(GLCreateShader shaderType withId) -> return $ GLCreateShader shaderType ((\me -> unsafePerformIO $ putMVar mme me >> return me) . withId)+		y@( GLDeleteShader _id        me)     -> putMVar mme me >> return y++		y@( GLShaderSource _shader _strings            me) -> putMVar mme me >> return y+		y@( GLCompileShader _id                        me) -> putMVar mme me >> return y+		y@( GLAttachShader _program _shader            me) -> putMVar mme me >> return y+		y@( GLDetachShader _program _shader            me) -> putMVar mme me >> return y+		y@( GLLinkProgram _program                     me) -> putMVar mme me >> return y+		y@( GLUseProgram _id                           me) -> putMVar mme me >> return y+		y@( GLProgramParameteri _program _pname _value me) -> putMVar mme me >> return y+		y@( GLBindProgramPipeline _id                  me) -> putMVar mme me >> return y++		y@( GLUseProgramStages _pipeline _stages _program me)        -> putMVar mme me >> return y+		_y@(GLGenProgramPipelines numNames                withNames) -> return $ GLGenProgramPipelines numNames ((\me -> unsafePerformIO $ putMVar mme me >> return me) . withNames)+		y@( GLDeleteProgramPipelines _pipelines           me)        -> putMVar mme me >> return y++		y@( GLGenerateMipmap        _target  me) -> putMVar mme me >> return y+		y@( GLGenerateTextureMipmap _texture me) -> putMVar mme me >> return y++		_y@(GLGetMaxVertexTextureImageUnits withNum) -> return $ GLGetMaxVertexTextureImageUnits ((\me -> unsafePerformIO $ putMVar mme me >> return me) . withNum)++		_y@(GLGetShaderiv       shader  pname withOut) -> return $ GLGetShaderiv       shader  pname ((\me -> unsafePerformIO $ putMVar mme me >> return me) . withOut)+		_y@(GLGetProgramiv      program pname withOut) -> return $ GLGetProgramiv      program pname ((\me -> unsafePerformIO $ putMVar mme me >> return me) . withOut)+		_y@(GLGetShaderInfoLog  shader        withLog) -> return $ GLGetShaderInfoLog  shader        ((\me -> unsafePerformIO $ putMVar mme me >> return me) . withLog)+		_y@(GLGetProgramInfoLog program       withLog) -> return $ GLGetProgramInfoLog program       ((\me -> unsafePerformIO $ putMVar mme me >> return me) . withLog)++		y@( GLUniform1f  _location _v0             me) -> putMVar mme me >> return y+		y@( GLUniform2f  _location _v0 _v1         me) -> putMVar mme me >> return y+		y@( GLUniform3f  _location _v0 _v1 _v2     me) -> putMVar mme me >> return y+		y@( GLUniform4f  _location _v0 _v1 _v2 _v3 me) -> putMVar mme me >> return y+		y@( GLUniform1i  _location _v0             me) -> putMVar mme me >> return y+		y@( GLUniform2i  _location _v0 _v1         me) -> putMVar mme me >> return y+		y@( GLUniform3i  _location _v0 _v1 _v2     me) -> putMVar mme me >> return y+		y@( GLUniform4i  _location _v0 _v1 _v2 _v3 me) -> putMVar mme me >> return y+		y@( GLUniform1ui _location _v0             me) -> putMVar mme me >> return y+		y@( GLUniform2ui _location _v0 _v1         me) -> putMVar mme me >> return y+		y@( GLUniform3ui _location _v0 _v1 _v2     me) -> putMVar mme me >> return y+		y@( GLUniform4ui _location _v0 _v1 _v2 _v3 me) -> putMVar mme me >> return y++		_y@(GLGetlUniformfv  program location len withOuts) -> return $ GLGetlUniformfv  program location len ((\me -> unsafePerformIO $ putMVar mme me >> return me) . withOuts)+		_y@(GLGetlUniformiv  program location len withOuts) -> return $ GLGetlUniformiv  program location len ((\me -> unsafePerformIO $ putMVar mme me >> return me) . withOuts)+		_y@(GLGetlUniformuiv program location len withOuts) -> return $ GLGetlUniformuiv program location len ((\me -> unsafePerformIO $ putMVar mme me >> return me) . withOuts)+		_y@(GLGetlUniformdv  program location len withOuts) -> return $ GLGetlUniformdv  program location len ((\me -> unsafePerformIO $ putMVar mme me >> return me) . withOuts)++		_y@(GLGenBuffers    num    withNames) -> return $ GLGenBuffers num ((\me -> unsafePerformIO $ putMVar mme me >> return me) . withNames)+		y@( GLDeleteBuffers _names me)        -> putMVar mme me >> return y++		y@( GLNamedBufferData    _buffer         _data _usage me) -> putMVar mme me >> return y+		y@( GLNamedBufferSubData _buffer _offset _data        me) -> putMVar mme me >> return y+		y@( GLBufferData         _target         _data _usage me) -> putMVar mme me >> return y+		y@( GLBufferSubData      _target _offset _data        me) -> putMVar mme me >> return y++		_y@(GLGenVertexArrays    num    withNames) -> return $ GLGenVertexArrays num ((\me -> unsafePerformIO $ putMVar mme me >> return me) . withNames)+		y@( GLDeleteVertexArrays _names me)        -> putMVar mme me >> return y++		y@( GLBindBuffer      _target        _buffer               me) -> putMVar mme me >> return y+		y@( GLBindBufferBase  _target _index _buffer               me) -> putMVar mme me >> return y+		y@( GLBindBufferRange _target _index _buffer _offset _size me) -> putMVar mme me >> return y++		y@( GLBindVertexArray _array me) -> putMVar mme me >> return y++		y@( GLVertexAttribPointer  _index _size _type _normalized _stride _offset me) -> putMVar mme me >> return y+		y@( GLVertexAttribIPointer _index _size _type             _stride _offset me) -> putMVar mme me >> return y+		y@( GLVertexAttribLPointer _index _size _type             _stride _offset me) -> putMVar mme me >> return y++		y@( GLEnableVertexArrayAttrib  _vaobj _index me) -> putMVar mme me >> return y+		y@( GLDisableVertexArrayAttrib _vaobj _index me) -> putMVar mme me >> return y+		y@( GLEnableVertexAttribArray         _index me) -> putMVar mme me >> return y+		y@( GLDisableVertexAttribArray        _index me) -> putMVar mme me >> return y++		--y@( GLDrawElements     _mode              _indices me) -> putMVar mme me >> return y+		--y@( GLDrawElementsData _mode _count _type _indices me) -> putMVar mme me >> return y+		y@( GLDrawElementsRaw _mode _count _type _offset   me) -> putMVar mme me >> return y+		y@( GLDrawArrays      _mode _first _count          me) -> putMVar mme me >> return y++		_y@(GLGetString  name        withString) -> return $ GLGetString  name        ((\me -> unsafePerformIO $ putMVar mme me >> return me) . withString)+		_y@(GLGetStringi name index_ withString) -> return $ GLGetStringi name index_ ((\me -> unsafePerformIO $ putMVar mme me >> return me) . withString)++		y@( GLDepthRange                           _nearVal _farVal me) -> putMVar mme me >> return y+		y@( GLOrtho      _left _right _bottom _top _nearVal _farVal me) -> putMVar mme me >> return y++		y@( GLCullFace _mode me) -> putMVar mme me >> return y++instance Applicative GLIOF where+	pure = PureGLIOF+	mf <*> ma = JoinGLIOF . flip fmap mf $ \f -> JoinGLIOF .  flip fmap ma $ \a -> pure (f a)+instance Monad GLIOF where+	return = pure+	m >>= f = JoinGLIOF $ f <$> m+instance MonadFix GLIOF where+	mfix :: (a -> GLIOF a) -> GLIOF a+	mfix = fixGLIOF++-- * Runners++runGLIOIO :: GLIOF (IO ()) -> IO ()++runGLIOIO (EmptyGLIOF)      = return ()+runGLIOIO (PureGLIOF a)     = a+runGLIOIO (UnfixGLIOF glio) = runGLIOIO glio+runGLIOIO (JoinGLIOF glio)  = runGLIOIO $ runGLIOIO <$> glio++runGLIOIO (GLClear          mask_2               glio) = glClear       mask_2               >> glio+runGLIOIO (GLClearColor     red green blue alpha glio) = hglClearColor red green blue alpha >> glio+runGLIOIO (GLTexImage2D     target level internalformat width height border format type_ data_ glio) = hglTexImage2D target level internalformat width height border format type_ data_ >> glio+runGLIOIO (GLGenTextures    numNames             withNames) = hglGenTextures numNames       >>= withNames+runGLIOIO (GLBindTexture    target texture       glio) = glBindTexture target texture       >> glio+runGLIOIO (GLDeleteTextures textures             glio) = hglDeleteTextures textures         >> glio+runGLIOIO (GLGetError                            withError) = glGetError                    >>= withError++runGLIOIO (GLColor4d  red green blue alpha             glio) = glColor4d  red green blue alpha              >> glio+runGLIOIO (GLBegin    mode                             glio) = glBegin    mode                              >> glio+runGLIOIO (GLVertex2d x y                              glio) = glVertex2d x y                               >> glio+runGLIOIO (GLEnd                                       glio) = glEnd                                        >> glio+runGLIOIO (GLActiveTexture texture                     glio) = glActiveTexture texture                      >> glio+runGLIOIO (GLClientActiveTexture texture               glio) = glClientActiveTexture texture                >> glio+runGLIOIO (GLEnable cap                                glio) = glEnable cap                                 >> glio+runGLIOIO (GLDisable cap                               glio) = glDisable cap                                >> glio+runGLIOIO (GLEnablei cap index_                        glio) = glEnablei cap index_                         >> glio+runGLIOIO (GLDisablei cap index_                       glio) = glDisablei cap index_                        >> glio+runGLIOIO (GLTexCoord2d s t                            glio) = glTexCoord2d s t                             >> glio+runGLIOIO (GLTexEnvf target pname param                glio) = glTexEnvf target pname param                 >> glio+runGLIOIO (GLTexEnvi target pname param                glio) = glTexEnvi target pname param                 >> glio+runGLIOIO (GLTexEnvfv target pname params              glio) = hglTexEnvfv target pname params              >> glio+runGLIOIO (GLTexEnviv target pname params              glio) = hglTexEnviv target pname params              >> glio+runGLIOIO (GLTexParameterf target pname param          glio) = glTexParameterf target pname param           >> glio+runGLIOIO (GLTexParameteri target pname param          glio) = glTexParameteri target pname param           >> glio+runGLIOIO (GLTextureParameterf texture pname param     glio) = glTextureParameterf texture pname param      >> glio+runGLIOIO (GLTextureParameteri texture pname param     glio) = glTextureParameteri texture pname param      >> glio+runGLIOIO (GLTexParameterfv target pname params        glio) = hglTexParameterfv target pname params        >> glio+runGLIOIO (GLTexParameteriv target pname params        glio) = hglTexParameteriv target pname params        >> glio+runGLIOIO (GLTexParameterIiv target pname params       glio) = hglTexParameterIiv target pname params       >> glio+runGLIOIO (GLTexParameterIuiv target pname params      glio) = hglTexParameterIuiv target pname params      >> glio+runGLIOIO (GLTextureParameterfv texture pname params   glio) = hglTextureParameterfv texture pname params   >> glio+runGLIOIO (GLTextureParameteriv texture pname params   glio) = hglTextureParameteriv texture pname params   >> glio+runGLIOIO (GLTextureParameterIiv texture pname params  glio) = hglTextureParameterIiv texture pname params  >> glio+runGLIOIO (GLTextureParameterIuiv texture pname params glio) = hglTextureParameterIuiv texture pname params >> glio++runGLIOIO (GLDepthMask flag glio) = glDepthMask flag >> glio+runGLIOIO (GLDepthFunc func glio) = glDepthFunc func >> glio++runGLIOIO (GLBlendEquationSeparate modeRGB modeAlpha      glio) = glBlendEquationSeparate modeRGB modeAlpha      >> glio+runGLIOIO (GLBlendEquationSeparatei buf modeRGB modeAlpha glio) = glBlendEquationSeparatei buf modeRGB modeAlpha >> glio++runGLIOIO (GLBlendFuncSeparate srcRGB dstRGB srcAlpha dstAlpha      glio) = glBlendFuncSeparate srcRGB dstRGB srcAlpha dstAlpha      >> glio+runGLIOIO (GLBlendFuncSeparatei buf srcRGB dstRGB srcAlpha dstAlpha glio) = glBlendFuncSeparatei buf srcRGB dstRGB srcAlpha dstAlpha >> glio++runGLIOIO (GLCreateProgram           withId) = glCreateProgram           >>= withId+runGLIOIO (GLDeleteProgram id_       glio)   = glDeleteProgram id_       >> glio+runGLIOIO (GLCreateShader shaderType withId) = glCreateShader shaderType >>= withId+runGLIOIO (GLDeleteShader id_        glio)   = glDeleteShader id_        >> glio++runGLIOIO (GLShaderSource shader strings           glio) = hglShaderSource shader strings          >> glio+runGLIOIO (GLCompileShader id_                     glio) = glCompileShader id_                     >> glio+runGLIOIO (GLAttachShader program shader           glio) = glAttachShader program shader           >> glio+runGLIOIO (GLDetachShader program shader           glio) = glDetachShader program shader           >> glio+runGLIOIO (GLLinkProgram program                   glio) = glLinkProgram program                   >> glio+runGLIOIO (GLUseProgram id_                        glio) = glUseProgram id_                        >> glio+runGLIOIO (GLProgramParameteri program pname value glio) = glProgramParameteri program pname value >> glio+runGLIOIO (GLBindProgramPipeline id_               glio) = glBindProgramPipeline id_               >> glio++runGLIOIO (GLUseProgramStages pipeline stages program glio)      = glUseProgramStages pipeline stages program >> glio+runGLIOIO (GLGenProgramPipelines    numNames          withNames) = hglGenTextures numNames                    >>= withNames+runGLIOIO (GLDeleteProgramPipelines pipelines         glio)      = hglDeleteTextures pipelines                >> glio++runGLIOIO (GLGenerateMipmap        target  glio) = glGenerateMipmap        target  >> glio+runGLIOIO (GLGenerateTextureMipmap texture glio) = glGenerateTextureMipmap texture >> glio++runGLIOIO (GLGetMaxVertexTextureImageUnits withNum) = hglGetMaxVertexTextureImageUnits >>= withNum++runGLIOIO (GLGetShaderiv       shader  pname withOut) = hglGetShaderiv       shader  pname >>= withOut+runGLIOIO (GLGetProgramiv      program pname withOut) = hglGetProgramiv      program pname >>= withOut+runGLIOIO (GLGetShaderInfoLog  shader        withLog) = hglGetShaderInfoLog  shader        >>= withLog+runGLIOIO (GLGetProgramInfoLog program       withLog) = hglGetProgramInfoLog program       >>= withLog++runGLIOIO (GLUniform1f  location v0          glio) = glUniform1f  location v0          >> glio+runGLIOIO (GLUniform2f  location v0 v1       glio) = glUniform2f  location v0 v1       >> glio+runGLIOIO (GLUniform3f  location v0 v1 v2    glio) = glUniform3f  location v0 v1 v2    >> glio+runGLIOIO (GLUniform4f  location v0 v1 v2 v3 glio) = glUniform4f  location v0 v1 v2 v3 >> glio+runGLIOIO (GLUniform1i  location v0          glio) = glUniform1i  location v0          >> glio+runGLIOIO (GLUniform2i  location v0 v1       glio) = glUniform2i  location v0 v1       >> glio+runGLIOIO (GLUniform3i  location v0 v1 v2    glio) = glUniform3i  location v0 v1 v2    >> glio+runGLIOIO (GLUniform4i  location v0 v1 v2 v3 glio) = glUniform4i  location v0 v1 v2 v3 >> glio+runGLIOIO (GLUniform1ui location v0          glio) = glUniform1ui location v0          >> glio+runGLIOIO (GLUniform2ui location v0 v1       glio) = glUniform2ui location v0 v1       >> glio+runGLIOIO (GLUniform3ui location v0 v1 v2    glio) = glUniform3ui location v0 v1 v2    >> glio+runGLIOIO (GLUniform4ui location v0 v1 v2 v3 glio) = glUniform4ui location v0 v1 v2 v3 >> glio++runGLIOIO (GLGetlUniformfv  program location len withOuts) = hglGetlUniformfv  program location len >>= withOuts+runGLIOIO (GLGetlUniformiv  program location len withOuts) = hglGetlUniformiv  program location len >>= withOuts+runGLIOIO (GLGetlUniformuiv program location len withOuts) = hglGetlUniformuiv program location len >>= withOuts+runGLIOIO (GLGetlUniformdv  program location len withOuts) = hglGetlUniformdv  program location len >>= withOuts++runGLIOIO (GLGenBuffers    num   withNames) = hglGenBuffers    num   >>= withNames+runGLIOIO (GLDeleteBuffers names glio)      = hglDeleteBuffers names >> glio++runGLIOIO (GLNamedBufferData    buffer        data_ usage glio) = hglNamedBufferData    buffer        data_ usage >> glio+runGLIOIO (GLNamedBufferSubData buffer offset data_       glio) = hglNamedBufferSubData buffer offset data_       >> glio+runGLIOIO (GLBufferData         target        data_ usage glio) = hglBufferData         target        data_ usage >> glio+runGLIOIO (GLBufferSubData      target offset data_       glio) = hglBufferSubData      target offset data_       >> glio++runGLIOIO (GLGenVertexArrays    num   withNames) = hglGenVertexArrays    num   >>= withNames+runGLIOIO (GLDeleteVertexArrays names glio)      = hglDeleteVertexArrays names >> glio++runGLIOIO (GLBindBuffer      target        buffer             glio) = glBindBuffer      target        buffer             >> glio+runGLIOIO (GLBindBufferBase  target index_ buffer             glio) = glBindBufferBase  target index_ buffer             >> glio+runGLIOIO (GLBindBufferRange target index_ buffer offset size glio) = glBindBufferRange target index_ buffer offset size >> glio++runGLIOIO (GLBindVertexArray array_ glio) = glBindVertexArray array_ >> glio++runGLIOIO (GLVertexAttribPointer  index_ size type_ normalized stride offset glio) = hglVertexAttribPointer  index_ size type_ normalized stride offset >> glio+runGLIOIO (GLVertexAttribIPointer index_ size type_            stride offset glio) = hglVertexAttribIPointer index_ size type_            stride offset >> glio+runGLIOIO (GLVertexAttribLPointer index_ size type_            stride offset glio) = hglVertexAttribLPointer index_ size type_            stride offset >> glio++runGLIOIO (GLEnableVertexArrayAttrib  vaobj index_ glio) = glEnableVertexArrayAttrib  vaobj index_ >> glio+runGLIOIO (GLDisableVertexArrayAttrib vaobj index_ glio) = glDisableVertexArrayAttrib vaobj index_ >> glio+runGLIOIO (GLEnableVertexAttribArray        index_ glio) = glEnableVertexAttribArray        index_ >> glio+runGLIOIO (GLDisableVertexAttribArray       index_ glio) = glDisableVertexAttribArray       index_ >> glio++--runGLIOIO (GLDrawElements     mode             indices_ glio) = hglDrawElements     mode             indices_ >> glio+--runGLIOIO (GLDrawElementsData mode count type_ indices_ glio) = hglDrawElementsData mode count type_ indices_ >> glio+runGLIOIO (GLDrawElementsRaw mode count type_ offset    glio) = hglDrawElementsRaw mode count type_ offset    >> glio+runGLIOIO (GLDrawArrays      mode first count           glio) = glDrawArrays       mode first count           >> glio++runGLIOIO (GLGetString  name        withString) = hglGetString  name        >>= withString+runGLIOIO (GLGetStringi name index_ withString) = hglGetStringi name index_ >>= withString++runGLIOIO (GLDepthRange                       nearVal farVal glio) = glDepthRange                       nearVal farVal >> glio+runGLIOIO (GLOrtho      left right bottom top nearVal farVal glio) = glOrtho      left right bottom top nearVal farVal >> glio++runGLIOIO (GLCullFace mode glio) = glCullFace mode >> glio++hglClearColor :: GLdouble -> GLdouble -> GLdouble -> GLdouble -> IO ()+hglClearColor red green blue alpha = glClearColor (realToFrac red) (realToFrac green) (realToFrac blue) (realToFrac alpha)++hglTexImage2D :: GLenum -> GLint -> GLint -> GLsizei -> GLsizei -> GLint -> GLenum -> GLenum -> GLData -> IO ()+hglTexImage2D target level internalformat width height border format type_ data_ = do+	let strict = glDataToBS data_  -- bytestrings only provides a CString interface for strict.+	BS.useAsCString strict $ \ptr -> glTexImage2D target level internalformat width height border format type_ (castPtr ptr)++hglGenTextures :: GLsizei -> IO [GLuint]+hglGenTextures numNames = do+	let len = fromIntegral numNames  :: Integer+	array_ <- newArray_ (0, numNames - 1)+	withStorableArray array_ $ \ptr -> glGenTextures (fromIntegral len) ptr+	names <- getElems array_+	return names++hglDeleteTextures :: [GLuint] -> IO ()+hglDeleteTextures textures = do+	array_ <- newListArray (0 :: Integer, genericLength textures - 1) textures+	len    <- getNumElements array_+	withStorableArray array_ $ \ptr -> glDeleteTextures (fromIntegral len) (castPtr ptr)++hglTexEnvfv :: GLenum -> GLenum -> [GLfloat] -> IO ()+hglTexEnvfv target pname params = do+	array_ <- newListArray (0 :: Integer, genericLength params - 1) params+	_len   <- getNumElements array_+	withStorableArray array_ $ \ptr -> glTexEnvfv target pname (castPtr ptr)++hglTexEnviv :: GLenum -> GLenum -> [GLint] -> IO ()+hglTexEnviv target pname params = do+	array_ <- newListArray (0 :: Integer, genericLength params - 1) params+	_len   <- getNumElements array_+	withStorableArray array_ $ \ptr -> glTexEnviv target pname (castPtr ptr)++hglTexParameterfv :: GLenum -> GLenum -> [GLfloat] -> IO ()+hglTexParameterfv target pname params = do+	array_ <- newListArray (0 :: Integer, genericLength params - 1) params+	_len   <- getNumElements array_+	withStorableArray array_ $ \ptr -> glTexParameterfv target pname (castPtr ptr)++hglTexParameteriv :: GLenum -> GLenum -> [GLint] -> IO ()+hglTexParameteriv target pname params = do+	array_ <- newListArray (0 :: Integer, genericLength params - 1) params+	_len   <- getNumElements array_+	withStorableArray array_ $ \ptr -> glTexParameteriv target pname (castPtr ptr)++hglTexParameterIiv :: GLenum -> GLenum -> [GLint] -> IO ()+hglTexParameterIiv target pname params = do+	array_ <- newListArray (0 :: Integer, genericLength params - 1) params+	_len   <- getNumElements array_+	withStorableArray array_ $ \ptr -> glTexParameterIiv target pname (castPtr ptr)++hglTexParameterIuiv :: GLenum -> GLenum -> [GLuint] -> IO ()+hglTexParameterIuiv target pname params = do+	array_ <- newListArray (0 :: Integer, genericLength params - 1) params+	_len   <- getNumElements array_+	withStorableArray array_ $ \ptr -> glTexParameterIuiv target pname (castPtr ptr)++hglTextureParameterfv :: GLenum -> GLenum -> [GLfloat] -> IO ()+hglTextureParameterfv texture pname params = do+	array_ <- newListArray (0 :: Integer, genericLength params - 1) params+	_len   <- getNumElements array_+	withStorableArray array_ $ \ptr -> glTextureParameterfv texture pname (castPtr ptr)++hglTextureParameteriv :: GLenum -> GLenum -> [GLint] -> IO ()+hglTextureParameteriv texture pname params = do+	array_ <- newListArray (0 :: Integer, genericLength params - 1) params+	_len   <- getNumElements array_+	withStorableArray array_ $ \ptr -> glTextureParameteriv texture pname (castPtr ptr)++hglTextureParameterIiv :: GLenum -> GLenum -> [GLint] -> IO ()+hglTextureParameterIiv texture pname params = do+	array_ <- newListArray (0 :: Integer, genericLength params - 1) params+	_len   <- getNumElements array_+	withStorableArray array_ $ \ptr -> glTextureParameterIiv texture pname (castPtr ptr)++hglTextureParameterIuiv :: GLenum -> GLenum -> [GLuint] -> IO ()+hglTextureParameterIuiv texture pname params = do+	array_ <- newListArray (0 :: Integer, genericLength params - 1) params+	_len   <- getNumElements array_+	withStorableArray array_ $ \ptr -> glTextureParameterIuiv texture pname (castPtr ptr)++hglShaderSource :: GLuint -> [String] -> IO ()+hglShaderSource shader strings0 = do+	let bstrings = numStrings `seq` map (BS.pack . map truncateChar) strings0+	foldr reduce reduction0 bstrings []+	where+		numStrings = genericLength strings0+		reduce :: BS.ByteString -> ([(Ptr CChar, Int)] -> IO ()) -> ([(Ptr CChar, Int)] -> IO ())+		reduce bstring withStrings = \strings -> BS.useAsCString bstring $ \cstring -> withStrings ((cstring, BS.length bstring):strings)+		reduction0 :: [(Ptr CChar, Int)] -> IO ()+		reduction0 reversedStrings = do+			let strings  = reverse reversedStrings+			let cstrings = map fst strings+			let lens     = map snd strings+			cstrArray <- newListArray (0 :: Integer, genericLength cstrings - 1) cstrings+			_cstrLen  <- getNumElements cstrArray+			lensArray <- newListArray (0 :: Integer, genericLength lens - 1) lens+			_lensLen  <- getNumElements lensArray+			withStorableArray cstrArray $ \cstrPtr -> withStorableArray lensArray $ \lensPtr ->+				glShaderSource shader numStrings (castPtr cstrPtr) (castPtr lensPtr)+		-- bytestring could really use a .UTF8 module, rather than just .Char8.+		truncateChar :: Char -> Word8+		truncateChar = toEnum . (min 255) . fromEnum++hglGenProgramPipelines :: GLsizei -> IO [GLuint]+hglGenProgramPipelines numNames = do+	let len = fromIntegral numNames  :: Integer+	array_ <- newArray_ (0, numNames - 1)+	withStorableArray array_ $ \ptr -> glGenProgramPipelines (fromIntegral len) ptr+	names <- getElems array_+	return names++hglDeleteProgramPipelines :: [GLuint] -> IO ()+hglDeleteProgramPipelines pipelines = do+	array_ <- newListArray (0 :: Integer, genericLength pipelines - 1) pipelines+	len    <- getNumElements array_+	withStorableArray array_ $ \ptr -> glDeleteProgramPipelines (fromIntegral len) (castPtr ptr)++hglGetMaxVertexTextureImageUnits :: IO GLint64+hglGetMaxVertexTextureImageUnits = do+	let numOuts = 1  :: Integer+	let safetyBuffer = 64+	let _len = fromIntegral (1 :: Integer)  :: Integer+	array_ <- newArray_ (0, numOuts - 1 + safetyBuffer)+	withStorableArray array_ $ \ptr -> glGetInteger64v GL_MAX_VERTEX_TEXTURE_IMAGE_UNITS ptr+	outs <- getElems array_+	let num = case outs of+		([])  -> error "Internal error: hglGetMaxVertexTextureImageUnits: empty array result."+		(x:_) -> x+	return num++-- | Currently the docs seem ot only specify single-param calls.+hglGetShaderiv :: GLuint -> GLenum -> IO GLint+hglGetShaderiv shader pname = do+	let numOuts = 1  :: Integer+	let safetyBuffer = 64+	let _len = fromIntegral (1 :: Integer)  :: Integer+	array_ <- newArray_ (0, numOuts - 1 + safetyBuffer)+	withStorableArray array_ $ \ptr -> glGetShaderiv shader pname ptr+	outs <- getElems array_+	let out = case outs of+		([])  -> error "Internal error: hglGetShaderiv: empty array result."+		(x:_) -> x+	return out++-- | Currently the docs seem ot only specify single-param calls.+hglGetProgramiv :: GLuint -> GLenum -> IO GLint+hglGetProgramiv program pname = do+	let numOuts = 1  :: Integer+	let safetyBuffer = 64+	let _len = fromIntegral (1 :: Integer)  :: Integer+	array_ <- newArray_ (0, numOuts - 1 + safetyBuffer)+	withStorableArray array_ $ \ptr -> glGetProgramiv program pname ptr+	outs <- getElems array_+	let out = case outs of+		([])  -> error "Internal error: hglGetProgramiv: empty array result."+		(x:_) -> x+	return out++hglGetlUniformfv :: GLuint -> GLint -> Integer -> IO [GLfloat]+hglGetlUniformfv program location len_ = do+	let len = max 0 $ len_+	let safetyBuffer = 16+	let z = 0.0 :: GLfloat  -- Also specifies the array value type.+	outsArray <- newArray (0, len - 1 + safetyBuffer) z+	withStorableArray outsArray $ \outsPtr -> glGetnUniformfv program location (fromIntegral $ len * (fromIntegral $ sizeOf z)) outsPtr+	outs <- genericTake len <$> getElems outsArray+	return outs++hglGetlUniformiv :: GLuint -> GLint -> Integer -> IO [GLint]+hglGetlUniformiv program location len_ = do+	let len = max 0 $ len_+	let safetyBuffer = 16+	let z = 0 :: GLint  -- Also specifies the array value type.+	outsArray <- newArray (0, len - 1 + safetyBuffer) z+	withStorableArray outsArray $ \outsPtr -> glGetnUniformiv program location (fromIntegral $ len * (fromIntegral $ sizeOf z)) outsPtr+	outs <- genericTake len <$> getElems outsArray+	return outs++hglGetlUniformuiv :: GLuint -> GLint -> Integer -> IO [GLuint]+hglGetlUniformuiv program location len_ = do+	let len = max 0 $ len_+	let safetyBuffer = 16+	let z = 0 :: GLuint  -- Also specifies the array value type.+	outsArray <- newArray (0, len - 1 + safetyBuffer) z+	withStorableArray outsArray $ \outsPtr -> glGetnUniformuiv program location (fromIntegral $ len * (fromIntegral $ sizeOf z)) outsPtr+	outs <- genericTake len <$> getElems outsArray+	return outs++hglGetlUniformdv :: GLuint -> GLint -> Integer -> IO [GLdouble]+hglGetlUniformdv program location len_ = do+	let len = max 0 $ len_+	let safetyBuffer = 16+	let z = 0.0 :: GLdouble  -- Also specifies the array value type.+	outsArray <- newArray (0, len - 1 + safetyBuffer) z+	withStorableArray outsArray $ \outsPtr -> glGetnUniformdv program location (fromIntegral $ len * (fromIntegral $ sizeOf z)) outsPtr+	outs <- genericTake len <$> getElems outsArray+	return outs++hglGetString :: GLenum -> IO BS.ByteString+hglGetString name = do+	bs <- glGetString name >>= \ptr -> BS.packCString (castPtr ptr)+	return bs++hglGetStringi :: GLenum -> GLuint -> IO BS.ByteString+hglGetStringi name index_ = do+	bs <- glGetStringi name index_ >>= \ptr -> BS.packCString (castPtr ptr)+	return bs++-- | glGetShaderInfoLog.+--+-- We don't know the size of the log without adding extra arguments,+-- so to make it length agnostic we attempt a length, but if the result is too+-- close in length, double the length and try again, up to a fixed limit, after+-- which we leave the truncation.+hglGetShaderInfoLog :: GLuint -> IO String+hglGetShaderInfoLog shader = trySize initialSize+	where+		initialSize :: Integer+		initialSize = 4096+		threshold :: Integer+		threshold = flip const (3 :: Integer) 8+		safetyBuffer :: Integer+		safetyBuffer = 64+		maxSize :: Integer+		maxSize = 100 * 1024 * 1024+		trySize :: Integer -> IO String+		trySize size_ = do+			let size = min maxSize size_++			let lenLen = 1 :: Integer+			let z = fromIntegral (0 :: Integer)+			lenArray <- newArray  (0, max 1 $ lenLen - 1 + safetyBuffer) z+			logArray <- newArray_ (0, max 1 $ size - 1 + safetyBuffer)+			withStorableArray lenArray $ \lenPtr ->+				withStorableArray logArray $ \logPtr ->+					glGetShaderInfoLog shader (fromIntegral size) lenPtr logPtr+			-- Also specifies the array value types.+			(len   :: GLsizei) <- readArray lenArray 0+			(_char :: GLchar ) <- readArray logArray 0+			if size < maxSize && (fromIntegral len) + threshold >= size+				then trySize (2 * size)+				else do+					log_ <- withStorableArray logArray $ \logPtr -> BS.packCStringLen (logPtr, fromIntegral len)+					let logStr = map asciiChar . BS.unpack $ log_+					return logStr+		-- bytestring could really use a .UTF8 module, rather than just .Char8.+		asciiChar :: Word8 -> Char+		asciiChar = toEnum . fromEnum++hglGetProgramInfoLog :: GLuint -> IO String+hglGetProgramInfoLog program = trySize initialSize+	where+		initialSize :: Integer+		initialSize = 4096+		threshold :: Integer+		threshold = flip const (3 :: Integer) 8+		safetyBuffer :: Integer+		safetyBuffer = 64+		maxSize :: Integer+		maxSize = 100 * 1024 * 1024+		trySize :: Integer -> IO String+		trySize size_ = do+			let size = min maxSize size_++			let lenLen = 1 :: Integer+			let z = fromIntegral (0 :: Integer)+			lenArray <- newArray  (0, max 1 $ lenLen - 1 + safetyBuffer) z+			logArray <- newArray_ (0, max 1 $ size - 1 + safetyBuffer)+			withStorableArray lenArray $ \lenPtr ->+				withStorableArray logArray $ \logPtr ->+					glGetProgramInfoLog program (fromIntegral size) lenPtr logPtr+			-- Also specifies the array value types.+			(len   :: GLsizei) <- readArray lenArray 0+			(_char :: GLchar ) <- readArray logArray 0+			if size < maxSize && (fromIntegral len) + threshold >= size+				then trySize (2 * size)+				else do+					log_ <- withStorableArray logArray $ \logPtr -> BS.packCStringLen (logPtr, fromIntegral len)+					let logStr = map asciiChar . BS.unpack $ log_+					return logStr+		-- bytestring could really use a .UTF8 module, rather than just .Char8.+		asciiChar :: Word8 -> Char+		asciiChar = toEnum . fromEnum++hglGenBuffers :: GLsizei -> IO [GLuint]+hglGenBuffers num = do+	let len = fromIntegral num  :: Integer+	array_ <- newArray_ (0, num - 1)+	withStorableArray array_ $ \ptr -> glGenBuffers (fromIntegral len) ptr+	names <- getElems array_+	return names++hglDeleteBuffers :: [GLuint] -> IO ()+hglDeleteBuffers names = do+	array_ <- newListArray (0 :: Integer, genericLength names - 1) names+	len    <- getNumElements array_+	withStorableArray array_ $ \ptr -> glDeleteBuffers (fromIntegral len) (castPtr ptr)++hglNamedBufferData :: GLuint -> GLData -> GLenum -> IO ()+hglNamedBufferData buffer data_ usage = do+	let strict = glDataToBS data_  -- bytestrings only provides a CString interface for strict.+	BS.useAsCStringLen strict $ \(ptr, len) -> do+		glNamedBufferData buffer (fromIntegral len) (castPtr ptr) usage++hglNamedBufferSubData :: GLuint -> Integer -> GLData -> IO ()+hglNamedBufferSubData buffer offset data_ = do+	let strict = glDataToBS data_  -- bytestrings only provides a CString interface for strict.+	BS.useAsCStringLen strict $ \(ptr, len) -> do+		glNamedBufferSubData buffer (fromIntegral offset) (fromIntegral len) (castPtr ptr)++hglBufferData :: GLenum -> GLData -> GLenum -> IO ()+hglBufferData target data_ usage = do+	let strict = glDataToBS data_  -- bytestrings only provides a CString interface for strict.+	BS.useAsCStringLen strict $ \(ptr, len) -> do+		glBufferData target (fromIntegral len) (castPtr ptr) usage++hglBufferSubData :: GLenum -> Integer -> GLData -> IO ()+hglBufferSubData target offset data_ = do+	let strict = glDataToBS data_  -- bytestrings only provides a CString interface for strict.+	BS.useAsCStringLen strict $ \(ptr, len) -> do+		glBufferSubData target (fromIntegral offset) (fromIntegral len) (castPtr ptr)++hglGenVertexArrays :: GLsizei -> IO [GLuint]+hglGenVertexArrays num = do+	let len = fromIntegral num  :: Integer+	array_ <- newArray_ (0, num - 1)+	withStorableArray array_ $ \ptr -> glGenVertexArrays (fromIntegral len) ptr+	names <- getElems array_+	return names++hglDeleteVertexArrays :: [GLuint] -> IO ()+hglDeleteVertexArrays names = do+	array_ <- newListArray (0 :: Integer, genericLength names - 1) names+	len    <- getNumElements array_+	withStorableArray array_ $ \ptr -> glDeleteVertexArrays (fromIntegral len) (castPtr ptr)++hglVertexAttribPointer :: GLuint -> GLint -> GLenum -> GLboolean -> GLsizei -> Integer -> IO ()+hglVertexAttribPointer index_ size type_ normalized stride offset_ = do+	let offset = castPtr $ nullPtr `plusPtr` (fromIntegral offset_)+	glVertexAttribPointer index_ size type_ normalized stride offset++hglVertexAttribIPointer :: GLuint -> GLint -> GLenum -> GLsizei -> Integer -> IO ()+hglVertexAttribIPointer index_ size type_ stride offset_ = do+	let offset = castPtr $ nullPtr `plusPtr` (fromIntegral offset_)+	glVertexAttribIPointer index_ size type_ stride offset++hglVertexAttribLPointer :: GLuint -> GLint -> GLenum -> GLsizei -> Integer -> IO ()+hglVertexAttribLPointer index_ size type_ stride offset_ = do+	let offset = castPtr $ nullPtr `plusPtr` (fromIntegral offset_)+	glVertexAttribLPointer index_ size type_ stride offset++{-+hglDrawElements :: GLenum -> [GLuint] -> IO ()+hglDrawElements mode indices_ = do+	array_ <- newListArray (0 :: Integer, genericLength indices_ - 1) indices_+	len    <- getNumElements array_+	withStorableArray array_ $ \ptr -> glDrawElements mode (fromIntegral len) GL_UNSIGNED_INT (castPtr ptr)+-}++{-+hglDrawElementsData :: GLenum -> GLsizei -> GLenum -> GLData -> IO ()+hglDrawElementsData mode count type_ indices_ = do+	let strict = glDataToBS indices_  -- bytestrings only provides a CString interface for strict.+	BS.useAsCStringLen strict $ \(ptr, _len) -> do+		glDrawElements mode count type_ (castPtr ptr)+-}++hglDrawElementsRaw :: GLenum -> GLsizei -> GLenum -> Integer -> IO()+hglDrawElementsRaw mode count type_ offset_ = do+	let offset = castPtr $ nullPtr `plusPtr` (fromIntegral offset_)+	glDrawElements mode count type_ offset++-- * GLIO aliases that apply the Fixed wrapper++mkEmptyGLIO :: GLIO+mkEmptyGLIO = Fixed $ EmptyGLIOF++mkPureGLIO :: GLIO -> GLIO+mkPureGLIO glio = Fixed $ PureGLIOF glio++mkUnfixGLIO :: GLIO -> GLIO+mkUnfixGLIO glio = Fixed $ UnfixGLIOF (getFixed glio)++mkJoinGLIO :: GLIO -> GLIO+mkJoinGLIO glio = Fixed $ JoinGLIOF (getFixed <$> getFixed glio)++mkGLClear :: GLbitfield -> GLIO -> GLIO+mkGLClear mask_2 glio = Fixed $ GLClear mask_2 glio++mkGLClearColor :: GLdouble -> GLdouble -> GLdouble -> GLdouble -> GLIO -> GLIO+mkGLClearColor red green blue alpha glio = Fixed $ GLClearColor red green blue alpha glio++mkGLTexImage2D :: GLenum -> GLint -> GLint -> GLsizei -> GLsizei -> GLint -> GLenum -> GLenum -> GLData -> GLIO -> GLIO+mkGLTexImage2D target level internalformat width height border format type_ data_ glio = Fixed $ GLTexImage2D target level internalformat width height border format type_ data_ glio++mkGLGenTextures :: GLsizei -> ([GLuint] -> GLIO) -> GLIO+mkGLGenTextures numNames withNames = Fixed $ GLGenTextures numNames withNames++mkGLBindTexture :: GLenum -> GLuint -> GLIO -> GLIO+mkGLBindTexture target texture glio = Fixed $ GLBindTexture target texture glio++mkGLDeleteTextures :: [GLuint] -> GLIO -> GLIO+mkGLDeleteTextures textures glio = Fixed $ GLDeleteTextures textures glio++mkGLGetError :: (GLenum -> GLIO) -> GLIO+mkGLGetError withError = Fixed $ GLGetError withError++mkGLColor4d :: GLdouble -> GLdouble -> GLdouble -> GLdouble -> GLIO -> GLIO+mkGLColor4d red green blue alpha glio = Fixed $ GLColor4d red green blue alpha glio++mkGLBegin :: GLenum -> GLIO -> GLIO+mkGLBegin mode glio = Fixed $ GLBegin mode glio++mkGLVertex2d :: GLdouble -> GLdouble -> GLIO -> GLIO+mkGLVertex2d x y glio = Fixed $ GLVertex2d x y glio++mkGLEnd :: GLIO -> GLIO+mkGLEnd glio = Fixed $ GLEnd glio++mkGLActiveTexture :: GLenum -> GLIO -> GLIO+mkGLActiveTexture texture glio = Fixed $ GLActiveTexture texture glio++mkGLClientActiveTexture :: GLenum -> GLIO -> GLIO+mkGLClientActiveTexture texture glio = Fixed $ GLClientActiveTexture texture glio++mkGLEnable :: GLenum -> GLIO -> GLIO+mkGLEnable cap glio = Fixed $ GLEnable cap glio++mkGLDisable :: GLenum -> GLIO -> GLIO+mkGLDisable cap glio = Fixed $ GLDisable cap glio++mkGLEnablei :: GLenum -> GLuint -> GLIO -> GLIO+mkGLEnablei cap index_ glio = Fixed $ GLEnablei cap index_ glio++mkGLDisablei :: GLenum -> GLuint -> GLIO -> GLIO+mkGLDisablei cap index_ glio = Fixed $ GLDisablei cap index_ glio++mkGLTexCoord2d :: GLdouble -> GLdouble -> GLIO -> GLIO+mkGLTexCoord2d s t glio = Fixed $ GLTexCoord2d s t glio++mkGLTexEnvf :: GLenum -> GLenum -> GLfloat -> GLIO -> GLIO+mkGLTexEnvf target pname param glio = Fixed $ GLTexEnvf target pname param glio++mkGLTexEnvi :: GLenum -> GLenum -> GLint -> GLIO -> GLIO+mkGLTexEnvi target pname param glio = Fixed $ GLTexEnvi target pname param glio++mkGLTexEnvfv :: GLenum -> GLenum -> [GLfloat] -> GLIO -> GLIO+mkGLTexEnvfv target pname params glio = Fixed $ GLTexEnvfv target pname params glio++mkGLTexEnviv :: GLenum -> GLenum -> [GLint] -> GLIO -> GLIO+mkGLTexEnviv target pname params glio = Fixed $ GLTexEnviv target pname params glio++mkGLTexParameterf :: GLenum -> GLenum -> GLfloat -> GLIO -> GLIO+mkGLTexParameterf target pname param glio = Fixed $ GLTexParameterf target pname param glio++mkGLTexParameteri :: GLenum -> GLenum -> GLint -> GLIO -> GLIO+mkGLTexParameteri target pname param glio = Fixed $ GLTexParameteri target pname param glio++mkGLTextureParameterf :: GLenum -> GLenum -> GLfloat -> GLIO -> GLIO+mkGLTextureParameterf texture pname param glio = Fixed $ GLTextureParameterf texture pname param glio++mkGLTextureParameteri :: GLenum -> GLenum -> GLint -> GLIO -> GLIO+mkGLTextureParameteri texture pname param glio = Fixed $ GLTextureParameteri texture pname param glio++mkGLTexParameterfv :: GLenum -> GLenum -> [GLfloat] -> GLIO -> GLIO+mkGLTexParameterfv target pname params glio = Fixed $ GLTexParameterfv target pname params glio++mkGLTexParameteriv :: GLenum -> GLenum -> [GLint] -> GLIO -> GLIO+mkGLTexParameteriv target pname params glio = Fixed $ GLTexParameteriv target pname params glio++mkGLTexParameterIiv :: GLenum -> GLenum -> [GLint] -> GLIO -> GLIO+mkGLTexParameterIiv target pname params glio = Fixed $ GLTexParameterIiv target pname params glio++mkGLTexParameterIuiv :: GLenum -> GLenum -> [GLuint] -> GLIO -> GLIO+mkGLTexParameterIuiv target pname params glio = Fixed $ GLTexParameterIuiv target pname params glio++mkGLTextureParameterfv :: GLenum -> GLenum -> [GLfloat] -> GLIO -> GLIO+mkGLTextureParameterfv texture pname params glio = Fixed $ GLTextureParameterfv texture pname params glio++mkGLTextureParameteriv :: GLenum -> GLenum -> [GLint] -> GLIO -> GLIO+mkGLTextureParameteriv texture pname params glio = Fixed $ GLTextureParameteriv texture pname params glio++mkGLTextureParameterIiv :: GLenum -> GLenum -> [GLint] -> GLIO -> GLIO+mkGLTextureParameterIiv texture pname params glio = Fixed $ GLTextureParameterIiv texture pname params glio++mkGLTextureParameterIuiv :: GLenum -> GLenum -> [GLuint] -> GLIO -> GLIO+mkGLTextureParameterIuiv texture pname params glio = Fixed $ GLTextureParameterIuiv texture pname params glio++mkGLDepthMask :: GLboolean -> GLIO -> GLIO+mkGLDepthMask flag glio = Fixed $ GLDepthMask flag glio++mkGLDepthFunc :: GLenum -> GLIO -> GLIO+mkGLDepthFunc func glio = Fixed $ GLDepthFunc func glio++mkGLBlendEquationSeparate :: GLenum -> GLenum -> GLIO -> GLIO+mkGLBlendEquationSeparate modeRGB modeAlpha glio = Fixed $ GLBlendEquationSeparate modeRGB modeAlpha glio++mkGLBlendEquationSeparatei :: GLuint -> GLenum -> GLenum -> GLIO -> GLIO+mkGLBlendEquationSeparatei buf modeRGB modeAlpha glio = Fixed $ GLBlendEquationSeparatei buf modeRGB modeAlpha glio++mkGLBlendFuncSeparate :: GLenum -> GLenum -> GLenum -> GLenum -> GLIO -> GLIO+mkGLBlendFuncSeparate srcRGB dstRGB srcALpha dstAlpha glio = Fixed $ GLBlendFuncSeparate srcRGB dstRGB srcALpha dstAlpha glio++mkGLBlendFuncSeparatei :: GLuint -> GLenum -> GLenum -> GLenum -> GLenum -> GLIO -> GLIO+mkGLBlendFuncSeparatei buf srcRGB dstRGB srcALpha dstAlpha glio = Fixed $ GLBlendFuncSeparatei buf srcRGB dstRGB srcALpha dstAlpha glio++mkGLCreateProgram :: (GLuint -> GLIO) -> GLIO+mkGLCreateProgram withId = Fixed $ GLCreateProgram withId++mkGLDeleteProgram :: GLuint -> GLIO -> GLIO+mkGLDeleteProgram id_ glio = Fixed $ GLDeleteProgram id_ glio++mkGLCreateShader :: GLenum -> (GLuint -> GLIO) -> GLIO+mkGLCreateShader shaderType withId = Fixed $ GLCreateShader shaderType withId++mkGLDeleteShader :: GLuint -> GLIO -> GLIO+mkGLDeleteShader id_ glio = Fixed $ GLDeleteShader id_ glio++mkGLShaderSource :: GLuint -> [String] -> GLIO -> GLIO+mkGLShaderSource shader strings glio = Fixed $ GLShaderSource shader strings glio++mkGLCompileShader :: GLuint -> GLIO -> GLIO+mkGLCompileShader id_ glio = Fixed $ GLCompileShader id_ glio++mkGLAttachShader :: GLuint -> GLuint -> GLIO -> GLIO+mkGLAttachShader program shader glio = Fixed $ GLAttachShader program shader glio++mkGLDetachShader :: GLuint -> GLuint -> GLIO -> GLIO+mkGLDetachShader program shader glio = Fixed $ GLDetachShader program shader glio++mkGLLinkProgram :: GLuint -> GLIO -> GLIO+mkGLLinkProgram program glio = Fixed $ GLLinkProgram program glio++mkGLUseProgram :: GLuint -> GLIO -> GLIO+mkGLUseProgram id_ glio = Fixed $ GLUseProgram id_ glio++mkGLProgramParameteri :: GLuint -> GLenum -> GLint -> GLIO -> GLIO+mkGLProgramParameteri program pname value glio = Fixed $ GLProgramParameteri program pname value glio++mkGLBindProgramPipeline :: GLuint -> GLIO -> GLIO+mkGLBindProgramPipeline id_ glio = Fixed $ GLBindProgramPipeline id_ glio++mkGLUseProgramStages :: GLuint -> GLbitfield -> GLuint -> GLIO -> GLIO+mkGLUseProgramStages pipeline stages program glio = Fixed $ GLUseProgramStages pipeline stages program glio++mkGLGenProgramPipelines :: GLsizei -> ([GLuint] -> GLIO) -> GLIO+mkGLGenProgramPipelines numNames withNames = Fixed $ GLGenProgramPipelines numNames withNames++mkGLDeleteProgramPipelines :: [GLuint] -> GLIO -> GLIO+mkGLDeleteProgramPipelines pipelines glio = Fixed $ GLDeleteProgramPipelines pipelines glio++mkGLGenerateMipmap :: GLenum -> GLIO -> GLIO+mkGLGenerateMipmap target glio = Fixed $ GLGenerateMipmap target glio++mkGLGenerateTextureMipmap :: GLuint -> GLIO -> GLIO+mkGLGenerateTextureMipmap texture glio = Fixed $ GLGenerateTextureMipmap texture glio++mkGLGetMaxVertexTextureImageUnits :: (GLint64 -> GLIO) -> GLIO+mkGLGetMaxVertexTextureImageUnits withNum = Fixed $ GLGetMaxVertexTextureImageUnits withNum++mkGLGetShaderiv :: GLuint -> GLenum -> (GLint -> GLIO) -> GLIO+mkGLGetShaderiv shader pname withOut = Fixed $ GLGetShaderiv shader pname withOut++mkGLGetProgramiv :: GLuint -> GLenum -> (GLint -> GLIO) -> GLIO+mkGLGetProgramiv program pname withOut = Fixed $ GLGetProgramiv program pname withOut++mkGLGetShaderInfoLog :: GLuint -> (String -> GLIO) -> GLIO+mkGLGetShaderInfoLog shader withLog = Fixed $ GLGetShaderInfoLog shader withLog++mkGLGetProgramInfoLog :: GLuint -> (String -> GLIO) -> GLIO+mkGLGetProgramInfoLog program withLog = Fixed $ GLGetProgramInfoLog program withLog++mkGLUniform1f :: GLint -> GLfloat -> GLIO -> GLIO+mkGLUniform1f location v0 glio = Fixed $ GLUniform1f location v0 glio++mkGLUniform2f :: GLint -> GLfloat -> GLfloat -> GLIO -> GLIO+mkGLUniform2f location v0 v1 glio = Fixed $ GLUniform2f location v0 v1 glio++mkGLUniform3f :: GLint -> GLfloat -> GLfloat -> GLfloat -> GLIO -> GLIO+mkGLUniform3f location v0 v1 v2 glio = Fixed $ GLUniform3f location v0 v1 v2 glio++mkGLUniform4f :: GLint -> GLfloat -> GLfloat -> GLfloat -> GLfloat -> GLIO -> GLIO+mkGLUniform4f location v0 v1 v2 v3 glio = Fixed $ GLUniform4f location v0 v1 v2 v3 glio++mkGLUniform1i :: GLint -> GLint -> GLIO -> GLIO+mkGLUniform1i location v0 glio = Fixed $ GLUniform1i location v0 glio++mkGLUniform2i :: GLint -> GLint -> GLint -> GLIO -> GLIO+mkGLUniform2i location v0 v1 glio = Fixed $ GLUniform2i location v0 v1 glio++mkGLUniform3i :: GLint -> GLint -> GLint -> GLint -> GLIO -> GLIO+mkGLUniform3i location v0 v1 v2 glio = Fixed $ GLUniform3i location v0 v1 v2 glio++mkGLUniform4i :: GLint -> GLint -> GLint -> GLint -> GLint -> GLIO -> GLIO+mkGLUniform4i location v0 v1 v2 v3 glio = Fixed $ GLUniform4i location v0 v1 v2 v3 glio++mkGLUniform1ui :: GLint -> GLuint -> GLIO -> GLIO+mkGLUniform1ui location v0 glio = Fixed $ GLUniform1ui location v0 glio++mkGLUniform2ui :: GLint -> GLuint -> GLuint -> GLIO -> GLIO+mkGLUniform2ui location v0 v1 glio = Fixed $ GLUniform2ui location v0 v1 glio++mkGLUniform3ui :: GLint -> GLuint -> GLuint -> GLuint -> GLIO -> GLIO+mkGLUniform3ui location v0 v1 v2 glio = Fixed $ GLUniform3ui location v0 v1 v2 glio++mkGLUniform4ui :: GLint -> GLuint -> GLuint -> GLuint -> GLuint -> GLIO -> GLIO+mkGLUniform4ui location v0 v1 v2 v3 glio = Fixed $ GLUniform4ui location v0 v1 v2 v3 glio++mkGLGetlUniformfv :: GLuint -> GLint -> Integer -> ([GLfloat] -> GLIO) -> GLIO+mkGLGetlUniformfv program location len withOuts = Fixed $ GLGetlUniformfv program location len withOuts++mkGLGetlUniformiv :: GLuint -> GLint -> Integer -> ([GLint] -> GLIO) -> GLIO+mkGLGetlUniformiv program location len withOuts = Fixed $ GLGetlUniformiv program location len withOuts++mkGLGetlUniformuiv :: GLuint -> GLint -> Integer -> ([GLuint] -> GLIO) -> GLIO+mkGLGetlUniformuiv program location len withOuts = Fixed $ GLGetlUniformuiv program location len withOuts++mkGLGetlUniformdv :: GLuint -> GLint -> Integer -> ([GLdouble] -> GLIO) -> GLIO+mkGLGetlUniformdv program location len withOuts = Fixed $ GLGetlUniformdv program location len withOuts++mkGLGenBuffers :: GLsizei -> ([GLuint] -> GLIO) -> GLIO+mkGLGenBuffers num withNames = Fixed $ GLGenBuffers num withNames++mkGLDeleteBuffers :: [GLuint] -> GLIO -> GLIO+mkGLDeleteBuffers names glio = Fixed $ GLDeleteBuffers names glio++mkGLNamedBufferData :: GLuint -> GLData -> GLenum -> GLIO -> GLIO+mkGLNamedBufferData buffer data_ usage glio = Fixed $ GLNamedBufferData buffer data_ usage glio++mkGLNamedBufferSubData :: GLuint -> Integer -> GLData -> GLIO -> GLIO+mkGLNamedBufferSubData buffer offset data_ glio = Fixed $ GLNamedBufferSubData buffer offset data_ glio++mkGLBufferData :: GLenum -> GLData -> GLenum -> GLIO -> GLIO+mkGLBufferData target data_ usage glio = Fixed $ GLBufferData target data_ usage glio++mkGLBufferSubData :: GLenum -> Integer -> GLData -> GLIO -> GLIO+mkGLBufferSubData target offset data_ glio = Fixed $ GLBufferSubData target offset data_ glio++mkGLGenVertexArrays :: GLsizei -> ([GLuint] -> GLIO) -> GLIO+mkGLGenVertexArrays num withNames = Fixed $ GLGenVertexArrays num withNames++mkGLDeleteVertexArrays :: [GLuint] -> GLIO -> GLIO+mkGLDeleteVertexArrays names glio = Fixed $ GLDeleteVertexArrays names glio++mkGLBindBuffer :: GLenum -> GLuint -> GLIO -> GLIO+mkGLBindBuffer target buffer glio = Fixed $ GLBindBuffer target buffer glio++mkGLBindBufferBase :: GLenum -> GLuint -> GLuint -> GLIO -> GLIO+mkGLBindBufferBase target index_ buffer glio = Fixed $ GLBindBufferBase target index_ buffer glio++mkGLBindBufferRange :: GLenum -> GLuint -> GLuint -> GLintptr -> GLsizeiptr -> GLIO -> GLIO+mkGLBindBufferRange target index_ buffer offset size glio = Fixed $ GLBindBufferRange target index_ buffer offset size glio++mkGLBindVertexArray :: GLuint -> GLIO -> GLIO+mkGLBindVertexArray array_ glio = Fixed $ GLBindVertexArray array_ glio++mkGLVertexAttribPointer :: GLuint -> GLint -> GLenum -> GLboolean -> GLsizei -> Integer -> GLIO -> GLIO+mkGLVertexAttribPointer index_ size type_ normalized stride offset glio = Fixed $ GLVertexAttribPointer index_ size type_ normalized stride offset glio++mkGLVertexAttribIPointer :: GLuint -> GLint -> GLenum -> GLsizei -> Integer -> GLIO -> GLIO+mkGLVertexAttribIPointer index_ size type_ stride offset glio = Fixed $ GLVertexAttribIPointer index_ size type_ stride offset glio++mkGLVertexAttribLPointer :: GLuint -> GLint -> GLenum -> GLsizei -> Integer -> GLIO -> GLIO+mkGLVertexAttribLPointer index_ size type_ stride offset glio = Fixed $ GLVertexAttribLPointer index_ size type_ stride offset glio++mkGLEnableVertexArrayAttrib :: GLuint -> GLuint -> GLIO -> GLIO+mkGLEnableVertexArrayAttrib vaobj index_ glio = Fixed $ GLEnableVertexArrayAttrib vaobj index_ glio++mkGLDisableVertexArrayAttrib :: GLuint -> GLuint -> GLIO -> GLIO+mkGLDisableVertexArrayAttrib vaobj index_ glio = Fixed $ GLDisableVertexArrayAttrib vaobj index_ glio++mkGLEnableVertexAttribArray :: GLuint -> GLIO -> GLIO+mkGLEnableVertexAttribArray index_ glio = Fixed $ GLEnableVertexAttribArray index_ glio++mkGLDisableVertexAttribArray :: GLuint -> GLIO -> GLIO+mkGLDisableVertexAttribArray index_ glio = Fixed $ GLDisableVertexAttribArray index_ glio++{-+mkGLDrawElements :: GLenum -> [GLuint] -> GLIO -> GLIO+mkGLDrawElements mode indices_ glio = Fixed $ GLDrawElements mode indices_ glio+-}++{-+mkGLDrawElementsData :: GLenum -> GLsizei -> GLenum -> GLData -> GLIO -> GLIO+mkGLDrawElementsData mode count type_ indices_ glio = Fixed $ GLDrawElementsData mode count type_ indices_ glio+-}++mkGLDrawElementsRaw :: GLenum -> GLsizei -> GLenum -> Integer -> GLIO -> GLIO+mkGLDrawElementsRaw mode count type_ offset glio = Fixed $ GLDrawElementsRaw mode count type_ offset glio++mkGLDrawArrays :: GLenum -> GLint -> GLsizei -> GLIO -> GLIO+mkGLDrawArrays mode first count glio = Fixed $ GLDrawArrays mode first count glio++mkGLGetString :: GLenum -> (BS.ByteString -> GLIO) -> GLIO+mkGLGetString name withString = Fixed $ GLGetString name withString++mkGLGetStringi :: GLenum -> GLuint -> (BS.ByteString -> GLIO) -> GLIO+mkGLGetStringi name index_ withString = Fixed $ GLGetStringi name index_ withString++mkGLDepthRange :: GLdouble -> GLdouble -> GLIO -> GLIO+mkGLDepthRange nearVal farVal glio = Fixed $ GLDepthRange nearVal farVal glio++mkGLOrtho :: GLdouble -> GLdouble -> GLdouble -> GLdouble -> GLdouble -> GLdouble -> GLIO -> GLIO+mkGLOrtho left right bottom top nearVal farVal glio = Fixed $ GLOrtho left right bottom top nearVal farVal glio++mkGLCullFace :: GLenum -> GLIO -> GLIO+mkGLCullFace mode glio = Fixed $ GLCullFace mode glio++-- * types++type GLData = BS.ByteString++glDataToBS :: GLData -> BS.ByteString+glDataToBS = id++glDataToBL :: GLData -> BL.ByteString+glDataToBL = BL.fromStrict++bsToGLData :: BS.ByteString -> GLData+bsToGLData = id++blToGLData :: BL.ByteString -> GLData+blToGLData = BL.toStrict
+ Immutaball/Share/ImmutaballIO/SDLIO.hs view
@@ -0,0 +1,366 @@+{-# 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 #-}++-- ImmutaballIO.hs.++{-# LANGUAGE Haskell2010 #-}+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, InstanceSigs, ScopedTypeVariables, ExistentialQuantification #-}++module Immutaball.Share.ImmutaballIO.SDLIO+	(+		-- * SDLIO+		SDLIO,+		SDLIOF(..),+		runSDLIO,++		-- * mfix+		FixSDLIOException(..),+		fixSDLIOExceptionToException,+		fixSDLIOExceptionFromException,+		PrematureEvaluationFixSDLIOException(..),+		EmptyFixSDLIOException(..),+		fixSDLIOF,+		unsafeFixSDLIOFTo,++		-- * Runners+		runSDLIOIO,+		hsdlttfRender,+		hsdlcaptureMouse,+		hsdlsetRelativeMouseMode,++		-- * SDLIO aliases that apply the Fixed wrapper+		mkSDLWithInit,+		mkSDLWithTTFInit,+		mkSDLPollEvent,+		mkSDLPollEventSync,+		mkSDLPollEvents,+		mkSDLPollEventsSync,+		mkSDLWithWindow,+		mkSDLWithGLContext,+		mkSDLGLSwapWindow,+		mkSDLTTFLoad,+		mkSDLTTFRender,+		mkSDLTTFRenderSync,+		mkSDLCaptureMouse,+		mkSDLSetRelativeMouseMode,++		-- * types+		SDLData,+		sdlDataToBS,+		sdlDataToBL,+		bsToSDLData,+		blToSDLData+	) where++import Prelude ()+import Immutaball.Prelude++import Data.Word+import Foreign.ForeignPtr+import Foreign.Ptr+import Foreign.Storable++import Control.Concurrent.Async+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BL+import qualified Data.Text as T+import Graphics.GL.Core45+import qualified SDL.Event+import qualified SDL.Font+import qualified SDL.Init+import qualified SDL.Raw.Enum+import qualified SDL.Raw.Event+import qualified SDL.Raw.Types+import qualified SDL.Vect+import qualified SDL.Video+import qualified SDL.Video.OpenGL+import qualified SDL.Video.Renderer++import Immutaball.Share.Math+import Immutaball.Share.Utils++-- (mfix imports.)+import Control.Concurrent.MVar+import Control.Exception+import Data.Typeable+import GHC.IO.Unsafe (unsafeDupableInterleaveIO)+import System.IO.Unsafe (unsafePerformIO)++-- * SDLIO++type SDLIO = Fixed SDLIOF+data SDLIOF me =+	  SDLWithInit [SDL.Init.InitFlag] me+	| SDLWithTTFInit me+	-- | WARNING: do not call directly to avoid undefined behavior, but only+	-- with OS thread management compliant with the requirements of+	-- 'SDL.Event.pollEvent':+	-- > You can only call this function in the OS thread that set the video mode.+	-- SDLManager can handle this.+	| SDLPollEvent (Async (Maybe SDL.Event.Event) -> me)+	| SDLPollEventSync (Maybe SDL.Event.Event -> me)+	| SDLPollEvents (Async [SDL.Event.Event] -> me)+	| SDLPollEventsSync ([SDL.Event.Event] -> me)+	-- | Automatically handles destruction after lifetime.+	| SDLWithWindow T.Text SDL.Video.WindowConfig (SDL.Video.Window -> me)+	-- _| SDLDestroyWindow SDL.Video.Window  -- We can already manage the lifetime with WithCreate.+	-- | Automatically calls 'glMakeCurrent'.  NOTE: automatically calls+	-- 'glFinish' upon destruction.+	| SDLWithGLContext SDL.Video.Window (SDL.Video.OpenGL.GLContext -> me)+	-- | SDLGLMakeCurrent SDL.Video.Window SDL.Video.OpenGL.GLContext  -- We can automatically call this.+	-- -- _| See notes on 'glDeleleteContext' and 'glFinish' before using.+	-- _| SDLGLDeleteContext SDL.Video.OpenGL.GLContext+	| SDLGLSwapWindow SDL.Video.Window me+	| SDLTTFLoad FilePath SDL.Font.PointSize (SDL.Font.Font -> me)+	-- | Tight RGBA encoding.  Caching recommended.+	| SDLTTFRender SDL.Font.Font T.Text (Async (WidthHeightI, SDLData) -> me)+	| SDLTTFRenderSync SDL.Font.Font T.Text ((WidthHeightI, SDLData) -> me)++	| SDLCaptureMouse Bool (Integer -> me)+	| SDLSetRelativeMouseMode Bool (Integer -> me)+instance Functor SDLIOF where+	fmap :: (a -> b) -> (SDLIOF a -> SDLIOF b)+	fmap f (SDLWithInit subsystems sdlio)         = SDLWithInit subsystems (f sdlio)+	fmap f (SDLWithTTFInit sdlio)                 = SDLWithTTFInit (f sdlio)+	fmap f (SDLPollEvent withMEvent)              = SDLPollEvent (f . withMEvent)+	fmap f (SDLPollEventSync withMEvent)          = SDLPollEventSync (f . withMEvent)+	fmap f (SDLPollEvents withEvents)             = SDLPollEvents (f . withEvents)+	fmap f (SDLPollEventsSync withEvents)         = SDLPollEventsSync (f .  withEvents)+	fmap f (SDLWithWindow title cfg withWindow  ) = SDLWithWindow title cfg (f . withWindow)+	fmap f (SDLWithGLContext window withCxt)      = SDLWithGLContext window (f . withCxt)+	fmap f (SDLGLSwapWindow window withUnit)      = SDLGLSwapWindow window (f withUnit)+	fmap f (SDLTTFLoad path size withFont)        = SDLTTFLoad path size (f . withFont)+	fmap f (SDLTTFRender font text withImage)     = SDLTTFRender font text (f . withImage)+	fmap f (SDLTTFRenderSync font text withImage) = SDLTTFRenderSync font text (f . withImage)+	fmap f (SDLCaptureMouse enable withSuccess)   = SDLCaptureMouse enable (f . withSuccess)+	fmap f (SDLSetRelativeMouseMode enable withSuccess) = SDLSetRelativeMouseMode enable (f . withSuccess)++runSDLIO :: SDLIO -> IO ()+runSDLIO sdlio = cata runSDLIOIO sdlio++-- TODO: revisit:+{-+instance Foldable SDLIOF where+	foldr :: (a -> b -> b) -> b -> SDLIOF a -> b+	foldr reduce reduction0 (SDLWithInit _subsystems sdlio) = reduce sdlio reduction0+instance Traversable SDLIOF where+	traverse :: Applicative f => (a -> f b) -> SDLIOF a -> f (SDLIOF b)+	traverse traversal (SDLWithInit subsystems sdlio) = pure SDLWithInit <*> pure subsystems <*> traversal sdlio+-}++-- * mfix++data FixSDLIOException = forall e. Exception e => FixSDLIOException e+instance Show FixSDLIOException where+	show (FixSDLIOException e) = show e+instance Exception FixSDLIOException+fixSDLIOExceptionToException :: Exception e => e -> SomeException+fixSDLIOExceptionToException = toException . FixSDLIOException+fixSDLIOExceptionFromException :: Exception e => SomeException -> Maybe e+fixSDLIOExceptionFromException x = do+	FixSDLIOException a <- fromException x+	cast a++data PrematureEvaluationFixSDLIOException = PrematureEvaluationFixSDLIOException+	deriving (Show)+instance Exception PrematureEvaluationFixSDLIOException where+	toException = fixSDLIOExceptionToException+	fromException = fixSDLIOExceptionFromException++data EmptyFixSDLIOException = EmptyFixSDLIOException+	deriving (Show)+instance Exception EmptyFixSDLIOException where+	toException = fixSDLIOExceptionToException+	fromException = fixSDLIOExceptionFromException++--    mfix f = mfix f >>= f+-- => mfix f = join $ f <$> mfix f+-- Incorrect: runs f twice.+	--x -> f undefined >>= mfix f+{-+fixSDLIOF :: (me -> SDLIOF me) -> SDLIOF me+fixSDLIOF f = case f (error "Error: fixSDLIOF: premature evaluation of result before we could start it!") of+	x -> joinSDLIOF $ f <$> x+-}+-- Do it like fixIO and fixST (see also their notes; it's a little tricky).+-- Use a lazily read MVar.+fixSDLIOF :: (me -> SDLIOF me) -> SDLIOF me+fixSDLIOF f = unsafePerformIO $ do+	mme <- newEmptyMVar+	return $ unsafeFixSDLIOFTo mme f++-- | Helper for fixSDLIOF.+unsafeFixSDLIOFTo :: MVar me -> (me -> SDLIOF me) -> SDLIOF me+unsafeFixSDLIOFTo mme f = unsafePerformIO $ do+	me_ <- unsafeDupableInterleaveIO (readMVar mme `catch` \BlockedIndefinitelyOnMVar -> throwIO PrematureEvaluationFixSDLIOException)+	case f me_ of+		y@( SDLWithInit _subsystems me)           -> putMVar mme me >> return y+		y@( SDLWithTTFInit me)                    -> putMVar mme me >> return y+		_y@(SDLPollEvent withMEvent)              -> return $ SDLPollEvent               ((\me -> unsafePerformIO $ putMVar mme me >> return me) . withMEvent)+		_y@(SDLPollEventSync withMEvent)          -> return $ SDLPollEventSync           ((\me -> unsafePerformIO $ putMVar mme me >> return me) . withMEvent)+		_y@(SDLPollEvents withEvents)             -> return $ SDLPollEvents              ((\me -> unsafePerformIO $ putMVar mme me >> return me) . withEvents)+		_y@(SDLPollEventsSync withEvents)         -> return $ SDLPollEventsSync          ((\me -> unsafePerformIO $ putMVar mme me >> return me) . withEvents)+		_y@(SDLWithWindow title cfg withWindow)   -> return $ SDLWithWindow    title cfg ((\me -> unsafePerformIO $ putMVar mme me >> return me) . withWindow)+		_y@(SDLWithGLContext window withCxt)      -> return $ SDLWithGLContext window    ((\me -> unsafePerformIO $ putMVar mme me >> return me) . withCxt)+		y@( SDLGLSwapWindow _window me)           -> putMVar mme me >> return y+		_y@(SDLTTFLoad path size withFont)        -> return $ SDLTTFLoad       path size ((\me -> unsafePerformIO $ putMVar mme me >> return me) . withFont)+		_y@(SDLTTFRender font text withImage)     -> return $ SDLTTFRender     font text ((\me -> unsafePerformIO $ putMVar mme me >> return me) . withImage)+		_y@(SDLTTFRenderSync font text withImage) -> return $ SDLTTFRenderSync font text ((\me -> unsafePerformIO $ putMVar mme me >> return me) . withImage)+		_y@(SDLCaptureMouse enable withSuccess)   -> return $ SDLCaptureMouse  enable    ((\me -> unsafePerformIO $ putMVar mme me >> return me) . withSuccess)+		_y@(SDLSetRelativeMouseMode enable withSuccess) -> return $ SDLSetRelativeMouseMode enable ((\me -> unsafePerformIO $ putMVar mme me >> return me) . withSuccess)++-- * Runners++runSDLIOIO :: SDLIOF (IO ()) -> IO ()+runSDLIOIO (SDLWithInit subsystems sdlioio) = do+	SDL.Init.initialize subsystems+	sdlioio+	SDL.Init.quit+runSDLIOIO (SDLWithTTFInit sdlioio) = do+	SDL.Font.initialize+	sdlioio+	SDL.Font.quit+runSDLIOIO (SDLPollEvent withMEvent) = withAsync SDL.Event.pollEvent withMEvent+runSDLIOIO (SDLPollEventSync withMEvent) = SDL.Event.pollEvent >>= withMEvent+runSDLIOIO (SDLPollEvents withEvents) = withAsync SDL.Event.pollEvents withEvents+runSDLIOIO (SDLPollEventsSync withEvents) = SDL.Event.pollEvents >>= withEvents+runSDLIOIO (SDLWithWindow title cfg withWindow) = do+	window <- SDL.Video.createWindow title cfg+	withWindow window+	SDL.Video.destroyWindow window+runSDLIOIO (SDLWithGLContext window withCxt) = do+	cxt <- SDL.Video.OpenGL.glCreateContext window+	withCxt cxt+	glFinish+	SDL.Video.OpenGL.glDeleteContext cxt+runSDLIOIO (SDLGLSwapWindow window withUnit) = do+	SDL.Video.OpenGL.glSwapWindow window+	withUnit+runSDLIOIO (SDLTTFLoad path size withFont) = do+	font <- SDL.Font.load path size+	withFont font+runSDLIOIO (SDLTTFRender font text withImage) = withAsync (hsdlttfRender font text) withImage+runSDLIOIO (SDLTTFRenderSync font text withImage) = hsdlttfRender font text >>= withImage+runSDLIOIO (SDLCaptureMouse enable withSuccess) = hsdlcaptureMouse enable >>= withSuccess+runSDLIOIO (SDLSetRelativeMouseMode enable withSuccess) = hsdlsetRelativeMouseMode enable >>= withSuccess++-- | Render to a tight RGBA image.+--+-- We need some low-level C-like processing to interface with the SDL+-- libraries.+hsdlttfRender :: SDL.Font.Font -> T.Text -> IO (WidthHeightI, SDLData)+hsdlttfRender font text = do+	let maxColorComponent = 255  :: Word8+	let mcc = maxColorComponent+	fmt0Surface <- SDL.Font.blended font (SDL.Vect.V4 mcc mcc mcc mcc) text++	-- Get a couple fields from fmt0Surface's pixel format.+	(fmt0SurfaceFmtFmt, fmt0SurfaceFmtPalette) <- do+		let (SDL.Video.Renderer.Surface fmt0SurfaceSurfacePtr _) = fmt0Surface+		(SDL.Raw.Types.Surface fmt0SurfacePixelFormatPtr _w0' _h0' _pixels0' _userdata0 _cliprect0 _refcount0) <- peek fmt0SurfaceSurfacePtr+		(SDL.Raw.Types.PixelFormat {SDL.Raw.Types.pixelFormatFormat = fmt0SurfaceFmtFmt, SDL.Raw.Types.pixelFormatPalette = fmt0SurfaceFmtPalette}) <- peek fmt0SurfacePixelFormatPtr+		return (fmt0SurfaceFmtFmt, fmt0SurfaceFmtPalette)++	let+		tightRGBA :: SDL.Raw.Types.PixelFormat+		tightRGBA = SDL.Raw.Types.PixelFormat {+			-- The documentation doesn't say what this field is.  I'll just copy it.+			SDL.Raw.Types.pixelFormatFormat        = fmt0SurfaceFmtFmt :: Word32,+			-- I may as well copy this field too.+			SDL.Raw.Types.pixelFormatPalette       = fmt0SurfaceFmtPalette :: (Ptr SDL.Raw.Types.Palette),+			SDL.Raw.Types.pixelFormatBitsPerPixel  = 32  :: Word8,+			SDL.Raw.Types.pixelFormatBytesPerPixel = 4  :: Word8,+			SDL.Raw.Types.pixelFormatRMask         = if' (SDL.Raw.Enum.SDL_BYTEORDER == SDL.Raw.Enum.SDL_BIG_ENDIAN) 0xFF000000 0x000000FF  :: Word32,+			SDL.Raw.Types.pixelFormatGMask         = if' (SDL.Raw.Enum.SDL_BYTEORDER == SDL.Raw.Enum.SDL_BIG_ENDIAN) 0x00FF0000 0x0000FF00  :: Word32,+			SDL.Raw.Types.pixelFormatBMask         = if' (SDL.Raw.Enum.SDL_BYTEORDER == SDL.Raw.Enum.SDL_BIG_ENDIAN) 0x0000FF00 0x00FF0000  :: Word32,+			SDL.Raw.Types.pixelFormatAMask         = if' (SDL.Raw.Enum.SDL_BYTEORDER == SDL.Raw.Enum.SDL_BIG_ENDIAN) 0x000000FF 0xFF000000  :: Word32+		}+	tightRGBAFmtFPtr <- mallocForeignPtrArray 1+	fmt1Surface <- withForeignPtr tightRGBAFmtFPtr $ \tightRGBAFmtPtr -> do+		poke tightRGBAFmtPtr tightRGBA+		let+			tightRGBA' :: SDL.Video.Renderer.SurfacePixelFormat+			tightRGBA' = SDL.Video.Renderer.SurfacePixelFormat tightRGBAFmtPtr+		fmt1Surface <- SDL.Video.Renderer.convertSurface fmt0Surface tightRGBA'+		return fmt1Surface+	--SDL.Video.Renderer.freeSurface fmt0Surface  -- We copied a pointer from fmt0; hold on until we free fmt1 just in case.+	let (SDL.Video.Renderer.Surface rawSurfacePtr _) = fmt1Surface+	(SDL.Raw.Types.Surface _fmt w' h' pixels' _userdata _cliprect _refcount) <- peek rawSurfacePtr+	let (w, h) = (fromIntegral w', fromIntegral h')+	w `seq` h `seq` pixels' `seq` return ()+	pixelsBs <- BS.packCStringLen $ (castPtr pixels', fromIntegral $ 4*w*h)+	--let pixelsBl = BL.fromStrict pixelsBs+	--let pixels = pixelsBl `seq` pixelsBl+	let pixels = pixelsBs `seq` pixelsBs+	let result = w `seq` h `seq` pixels `seq` ((w, h), pixels)+	result `seq` return ()+	SDL.Video.Renderer.freeSurface fmt0Surface+	SDL.Video.Renderer.freeSurface fmt1Surface+	return result++hsdlcaptureMouse :: Bool -> IO Integer+hsdlcaptureMouse enable = fromIntegral <$> SDL.Raw.Event.captureMouse enable++hsdlsetRelativeMouseMode :: Bool -> IO Integer+hsdlsetRelativeMouseMode enable = fromIntegral <$> SDL.Raw.Event.setRelativeMouseMode enable++-- * SDLIO aliases that apply the Fixed wrapper++mkSDLWithInit :: [SDL.Init.InitFlag] -> SDLIO -> SDLIO+mkSDLWithInit subsystems sdlio = Fixed $ SDLWithInit subsystems sdlio++mkSDLWithTTFInit :: SDLIO -> SDLIO+mkSDLWithTTFInit sdlio = Fixed $ SDLWithTTFInit sdlio++mkSDLPollEvent :: (Async (Maybe SDL.Event.Event) -> SDLIO) -> SDLIO+mkSDLPollEvent withMEvent = Fixed $ SDLPollEvent withMEvent++mkSDLPollEventSync :: (Maybe SDL.Event.Event -> SDLIO) -> SDLIO+mkSDLPollEventSync withMEvent = Fixed $ SDLPollEventSync withMEvent++mkSDLPollEvents :: (Async [SDL.Event.Event] -> SDLIO) -> SDLIO+mkSDLPollEvents withEvents = Fixed $ SDLPollEvents withEvents++mkSDLPollEventsSync :: ([SDL.Event.Event] -> SDLIO) -> SDLIO+mkSDLPollEventsSync withEvents = Fixed $ SDLPollEventsSync withEvents++mkSDLWithWindow :: T.Text -> SDL.Video.WindowConfig -> (SDL.Video.Window -> SDLIO) -> SDLIO+mkSDLWithWindow title cfg withWindow = Fixed $ SDLWithWindow title cfg withWindow++mkSDLWithGLContext :: SDL.Video.Window -> (SDL.Video.OpenGL.GLContext -> SDLIO) -> SDLIO+mkSDLWithGLContext window withCxt = Fixed $ SDLWithGLContext window withCxt++mkSDLGLSwapWindow :: SDL.Video.Window -> SDLIO -> SDLIO+mkSDLGLSwapWindow window withUnit = Fixed $ SDLGLSwapWindow window withUnit++mkSDLTTFLoad :: FilePath -> SDL.Font.PointSize -> (SDL.Font.Font -> SDLIO) -> SDLIO+mkSDLTTFLoad path size withFont = Fixed $ SDLTTFLoad path size withFont++mkSDLTTFRender :: SDL.Font.Font -> T.Text -> (Async (WidthHeightI, SDLData) -> SDLIO) -> SDLIO+mkSDLTTFRender font text withImage = Fixed $ SDLTTFRender font text withImage++mkSDLTTFRenderSync :: SDL.Font.Font -> T.Text -> ((WidthHeightI, SDLData) -> SDLIO) -> SDLIO+mkSDLTTFRenderSync font text withImage = Fixed $ SDLTTFRenderSync font text withImage++mkSDLCaptureMouse :: Bool -> (Integer -> SDLIO) -> SDLIO+mkSDLCaptureMouse enable withSuccess = Fixed $ SDLCaptureMouse enable withSuccess++mkSDLSetRelativeMouseMode :: Bool -> (Integer -> SDLIO) -> SDLIO+mkSDLSetRelativeMouseMode enable withSuccess = Fixed $ SDLSetRelativeMouseMode enable withSuccess++-- * types++type SDLData = BS.ByteString++sdlDataToBS :: SDLData -> BS.ByteString+sdlDataToBS = id++sdlDataToBL :: SDLData -> BL.ByteString+sdlDataToBL = BL.fromStrict++bsToSDLData :: BS.ByteString -> SDLData+bsToSDLData = id++blToSDLData :: BL.ByteString -> SDLData+blToSDLData = BL.toStrict
+ Immutaball/Share/Level.hs view
@@ -0,0 +1,23 @@+{-# 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.Share.Level+	(+		module Immutaball.Share.Level.Base,+		module Immutaball.Share.Level.Render,+		module Immutaball.Share.Level.Parser,+		module Immutaball.Share.Level.Utils+	) where++import Prelude ()+--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
@@ -0,0 +1,648 @@+{-# 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 #-}++-- Game.hs.++{-# LANGUAGE Haskell2010 #-}+{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, RankNTypes #-}++-- | Optionally, we can add our own extra information about a level file.+--+-- TODO: add a type variable for LevelSet in SolMeta to to remove ball+-- (Ball.LevelSets) dependency from Shared.  Use ‘SolMeta'’, and in Ball have+-- ‘type SolMeta = SolMeta' LevelSet’.+module Immutaball.Share.Level.Analysis+	(+		SolWithAnalysis(..), swaSol, swaSa, swaMeta,+		SolAnalysis(..), saRenderAnalysis, saPhysicsAnalysis,+		SolMeta(..), smPath, smLevelSet,+		sar, sap,+		SolRenderAnalysis(..), sraVertexData, sraVertexDataGPU, sraGeomData,+			sraGeomDataGPU, sraLumpData, sraLumpDataGPU, sraPathDoublesData,+			sraPathDoublesDataGPU, sraPathInt32sData, sraPathInt32sDataGPU,+			sraBodyData, sraBodyDataGPU, sraOpaqueGeoms, sraTransparentGeoms,+			sraGcArray, sraGcArrayGPU, sraNumOpaqueGeomPasses,+			sraNumTransparentGeomPasses, sraNumGeomPasses, sraAllGeomPassMv,+			sraAllGeomPassTextures, sraAllGeomPassGis, sraAllGeomPassMvGPU,+			sraAllGeomPassTexturesGPU, sraAllGeomPassGisGPU,+			sraGeomPassMvRanges, sraGeomPassTexturesRanges,+			sraGeomPassGisRanges, sraGeomPassMvRangesGPU,+			sraGeomPassTexturesRangesGPU, sraGeomPassGisRangesGPU,+			sraGeomPassBis, sraGeomPassBisGPU, sraTexcoordsDoubleData,+			sraTexcoordsDoubleDataGPU,+		GeomPass(..), gpBi, gpMv, gpTextures, gpTexturesGPU, gpGis, gpGisGPU,+		SolPhysicsAnalysis(..), spaLumpOutwardsSides,+			spaLumpOutwardsSidesNumNegatedNormals,+			spaLumpOutwardsSidesNumNotNegatedNormals, spaLumpAverageVertex,+			spaLumpVertexAdjacents, {-spaLumpGetVertexAdjacents, -}spaLumpPlanes,+		mkSolAnalysis,+		mkSolRenderAnalysis,+		getSpaLumpGetVertexAdjacents,+		mkSolPhysicsAnalysis+	) where++import Prelude ()+import Immutaball.Prelude++import Control.Arrow+import Control.Monad+import Data.Bits+import Data.Foldable+import Data.Function hiding (id, (.))+import Data.Int+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 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.Math+import Immutaball.Share.Utils+import Immutaball.Share.Video++data SolWithAnalysis = SolWithAnalysis {+	_swaSol  :: Sol,+	_swaSa   :: SolAnalysis,+	_swaMeta :: SolMeta+}+	deriving (Eq, Ord, Show)+--makeLenses ''SolWithAnalysis++data SolAnalysis = SolAnalysis {+	-- | Extra analysis of the sol useful for rendering.+	_saRenderAnalysis :: SolRenderAnalysis,++	-- | Extra analysis of the sol useful for physics.+	_saPhysicsAnalysis :: SolPhysicsAnalysis+}+	deriving (Eq, Ord, Show)+--makeLenses ''SolAnalysis++data SolMeta = SolMeta {+	-- | The path to the sol.+	_smPath :: String,++	-- | Whether the sol is as a level set containing the sol.+	_smLevelSet :: Maybe LevelSet+}+	deriving (Eq, Ord, Show)+--makeLenses ''SolMeta++-- sar, sap++-- | Extra data of the sol useful for rendering.+--+-- We reorder the data a bit.+--+-- We have 14 arrays of data for the GPU that can be uploaded and accesses as 5+-- SSBOs.+data SolRenderAnalysis = SolRenderAnalysis {+	-- | The basis of 'sraVertexData'.+	--+	-- It's an array of the concatenation of x y and z.  *3 index gets the start index, to x.+	_sraVertexData    :: Array Int32 ShaderDoubleType,+	-- | You can use an SSBO to upload the vertex array as a GLData+	-- (sized bytestring), and then use that SSBO in the shader.+	--+	-- The shaders can usefully use the current array of vertices.+	_sraVertexDataGPU :: GLData,++	-- | Get all triangles of the SOL.+	-- Represented as vi, vj, vk, ti, tj, tk, si, sj, sk.+	-- (Note we don't include mtrl (base texture) data here; the renderer can+	-- handle that with passes of up to 16 textures at once, recovering the+	-- geom index.)+	_sraGeomData    :: Array Int32 Int32,+	_sraGeomDataGPU :: GLData,++	-- | Each lump is range of geoms: g0, gc.+	--+	-- (Each geom is a set of textured triangles.)+	_sraLumpData    :: Array Int32 Int32,+	_sraLumpDataGPU :: GLData,++	-- | Path doubles: start position x y and z (3 doubles); path ints: next path, smooth flag (2 ints).+	_sraPathDoublesData    :: Array Int32 ShaderDoubleType,+	_sraPathDoublesDataGPU :: GLData,+	_sraPathInt32sData     :: Array Int32 Int32,+	_sraPathInt32sDataGPU  :: GLData,++	-- | Body data: initial translation path and g0 and gc (lumps), 3 ints.+	--+	-- When rendering, the renderer can use a uniform to tell the GPU what path+	-- the body is currently on, and the linear interpolation (0 to 1) for that+	-- path.  The GPU can also use the body's initial path to determine the+	-- relative positioning of the path when performing interpolation.+	--+	-- Bodies are sets of lumps that follow the same path.+	_sraBodyData     :: Array Int32 Int32,+	_sraBodyDataGPU  :: GLData,++	-- | A grouping of all opaque geoms by 16 textures at a time.+	_sraOpaqueGeoms      :: [GeomPass],+	_sraTransparentGeoms :: [GeomPass],++	-- | A convenience identity array of length 3 * num all geom indices.+	--+	-- This is convenient since it allows a convenient rendering pass to be+	-- performed by calling glDrawArrays with an index and count into this+	-- array, and the shaders can do the rest of the work.+	_sraGcArray    :: Array Int32 Int32,+	_sraGcArrayGPU :: GLData,++	-- Now aggregate the GeomPass lists, so they can be conveniently uploaded+	-- to the GPU in whole.+	_sraNumOpaqueGeomPasses      :: Integer,+	_sraNumTransparentGeomPasses :: Integer,+	_sraNumGeomPasses            :: Integer,++	-- The aggregate GeomPass mv, and gi&texture list arrays.++	-- | Concatenation of all geom pass gpMvs.+	_sraAllGeomPassMv       :: Array Int32 Int32,+	-- | Concatenation of all geom pass gpTextures.+	_sraAllGeomPassTextures :: Array Int32 Int32,+	-- | Concatenation of all geom pass gpGis.+	_sraAllGeomPassGis      :: Array Int32 Int32,++	-- | The GPU encoded data.+	_sraAllGeomPassMvGPU       :: GLData,+	-- | The GPU encoded data.+	_sraAllGeomPassTexturesGPU :: GLData,+	-- | The GPU encoded data.+	_sraAllGeomPassGisGPU      :: GLData,++	-- | For each geompass we have an elem pair that represents a range of the+	-- aggregate sraAllGeomPassMv array.  We can tell the GPU what geom pass we+	-- are on, and it can have access to gpMv for that GeomPass.  For each+	-- geompass, we add 2 elems: the starting index, and the count.+	_sraGeomPassMvRanges       :: Array Int32 Int32,+	-- | Same but for sraAllGeomPassTextures.+	_sraGeomPassTexturesRanges :: Array Int32 Int32,+	_sraGeomPassGisRanges      :: Array Int32 Int32,++	-- | The GPU encoded data.+	_sraGeomPassMvRangesGPU       :: GLData,+	_sraGeomPassTexturesRangesGPU :: GLData,+	_sraGeomPassGisRangesGPU      :: GLData,++	-- | Array of body indices for each geompass.+	_sraGeomPassBis    :: Array Int32 Int32,+	_sraGeomPassBisGPU :: GLData,++	-- | Array of texcoords concatenating, e.g. s0 t0 s1 t1 s2 t2 … sn tn+	-- The shader can use the vertex data to look up the ti, and then double it+	-- to get the base index for the 2 tex coord doubles (x and y for textures+	-- are often conventionally called s and t).+	_sraTexcoordsDoubleData    :: Array Int32 ShaderDoubleType,+	_sraTexcoordsDoubleDataGPU :: GLData+}+	deriving (Eq, Ord, Show)+--makeLenses ''SolRenderAnalysis++-- | A subset of geometry that can be rendered in a single pass.+data GeomPass = GeomPass {+	-- | Body.+	_gpBi :: Int32,++	-- | Materials used in this pass; up to array of 16.+	_gpMv :: Array Int32 Int32,++	-- | For each geom, provide an index 0-15 of the 'gpMv' array.+	-- This array is of equal size with 'gpGis'.+	_gpTextures    :: Array Int32 Int32,+	_gpTexturesGPU :: GLData,++	-- | The textured triangles to draw.+	-- Array of geom indices.+	_gpGis    :: Array Int32 Int32,+	_gpGisGPU :: GLData+}+	deriving (Eq, Ord, Show)+--makeLenses ''SolRenderAnalysis++-- | Extra data of the sol useful for physics.+data SolPhysicsAnalysis = SolPhysicsAnalysis {+	-- | OLD: actually SOL file lump sides I found were not the actual planes+	-- of the faces, so they're something else.  'spaLumpOutwardsSides'* are no+	-- longer needed.  Instead for now we'll construct our own set of planes.+	-- | The sides of a lump by lump index (li), ensured to be pointing+	-- outwards.+	_spaLumpOutwardsSides :: M.Map Int32 [Plane3 Double],+	_spaLumpOutwardsSidesNumNegatedNormals :: M.Map Int32 Integer,+	_spaLumpOutwardsSidesNumNotNegatedNormals :: M.Map Int32 Integer,++	-- | Find the mean vertex of a lump.+	_spaLumpAverageVertex :: M.Map Int32 (Vec3 Double),++	-- | For each lump, map its already indirected (can ‘solVv ! vi’ directly) vertex+	-- indices to the set of (likewise indirected) adjacent vertex indices.+	--+	-- We use this to build up 'spaLumpPlanes' by hand.+	--+	-- This is a map from lump index to a map of _indirected_ (i.e. direct)+	-- vertex indices to a set of indirected vertices.  Given a lump and one of+	-- its vertices, you can use it to find the set of all other vertices+	-- adjacent to it, i.e. all other vertices such that there is an edge+	-- directly connecting them.+	_spaLumpVertexAdjacents :: M.Map Int32 (M.Map Int32 (S.Set Int32)),+	-- | A utility for convenience that looks up in 'spaLumpVertexAdjacents',+	-- returning an empty set if there is a lookup failure anywhere.+	--_spaLumpGetVertexAdjacents :: Int32 -> Int32 -> S.Set Int32,+	-- We define this lense outside the record so that we don't lose+	-- ‘instance (Eq, Ord, Show)’.++	-- | 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]+}+	deriving (Eq, Ord, Show)+makeLenses ''SolWithAnalysis+makeLenses ''SolAnalysis+makeLenses ''SolMeta+makeLenses ''SolRenderAnalysis+makeLenses ''GeomPass+makeLenses ''SolPhysicsAnalysis++sar :: Lens' SolAnalysis SolRenderAnalysis+sar = saRenderAnalysis++sap :: Lens' SolAnalysis SolPhysicsAnalysis+sap = saPhysicsAnalysis++mkSolAnalysis :: IBContext' a -> Sol -> SolAnalysis+mkSolAnalysis cxt sol = fix $ \_sa -> SolAnalysis {+	_saRenderAnalysis  = mkSolRenderAnalysis  cxt sol,+	_saPhysicsAnalysis = mkSolPhysicsAnalysis cxt sol+}++mkSolRenderAnalysis :: IBContext' a -> Sol -> SolRenderAnalysis+mkSolRenderAnalysis cxt sol = fix $ \sra -> SolRenderAnalysis {+	_sraVertexData    = genArray (0, 3 * (sol^.solVc) - 1) $ \idx -> toShaderDoubleType $ divMod idx 3 & \(vi, coord) -> ((sol^.solVv) ! vi)^.(vertP.lcoord3 coord),+	_sraVertexDataGPU = gpuEncodeArray (sra^.sraVertexData),++	_sraGeomData    = genArray (0, 9 * (sol^.solGc) - 1) $ \idx -> divMod idx 9 & \(gi, ridx) -> geomRelIdx gi ridx,+	_sraGeomDataGPU = gpuEncodeArray (sra^.sraGeomData),++	_sraLumpData    = genArray (0, 2 * (sol^.solLc) - 1) $ \idx -> divMod idx 2 & \(li, ridx) -> lumpRelIdx li ridx,+	_sraLumpDataGPU = gpuEncodeArray (sra^.sraLumpData),++	_sraPathDoublesData    = genArray (0, 3 * (sol^.solPc) - 1) $ \idx -> toShaderDoubleType $ divMod idx 3 & \(pi_, ridx) -> pathDoubleRelIdx pi_ ridx,+	_sraPathDoublesDataGPU = gpuEncodeArray (sra^.sraPathDoublesData),++	_sraPathInt32sData    = genArray (0, 2 * (sol^.solPc) - 1) $ \idx -> divMod idx 2 & \(pi_, ridx) -> pathInt32RelIdx pi_ ridx,+	_sraPathInt32sDataGPU = gpuEncodeArray (sra^.sraPathInt32sData),++	_sraBodyData    = genArray (0, 3 * (sol^.solBc) - 1) $ \idx -> divMod idx 3 & \(bi, ridx) -> bodyRelIdx bi ridx,+	_sraBodyDataGPU = gpuEncodeArray (sra^.sraBodyData),++	_sraOpaqueGeoms      = concat . filter (not . null) . map (passGeom (cxt^.ibStaticConfig.x'cfgMaxPassTextures) False) . zip [0..] $ elems (sol^.solBv),+	_sraTransparentGeoms = concat . filter (not . null) . map (passGeom (cxt^.ibStaticConfig.x'cfgMaxPassTextures) True ) . zip [0..] $ elems (sol^.solBv),++	_sraGcArray    = genArray (0, 3 * (sol^.solGc) - 1) $ \idx -> idx,+	_sraGcArrayGPU = gpuEncodeArray (sra^.sraGcArray),++	_sraNumOpaqueGeomPasses      = genericLength (sra^.sraOpaqueGeoms),+	_sraNumTransparentGeomPasses = genericLength (sra^.sraTransparentGeoms),+	_sraNumGeomPasses            = (sra^.sraNumOpaqueGeomPasses) + (sra^.sraNumTransparentGeomPasses),++	_sraAllGeomPassMv       = listArray'_ $ [mi      | geomPasses <- [sra^.sraOpaqueGeoms, sra^.sraTransparentGeoms], geomPass <- geomPasses, mi      <- elems (geomPass^.gpMv)      ],+	_sraAllGeomPassTextures = listArray'_ $ [texture | geomPasses <- [sra^.sraOpaqueGeoms, sra^.sraTransparentGeoms], geomPass <- geomPasses, texture <- elems (geomPass^.gpTextures)],+	_sraAllGeomPassGis      = listArray'_ $ [gi      | geomPasses <- [sra^.sraOpaqueGeoms, sra^.sraTransparentGeoms], geomPass <- geomPasses, gi      <- elems (geomPass^.gpGis)     ],++	_sraAllGeomPassMvGPU       = gpuEncodeArray (sra^.sraAllGeomPassMv),+	_sraAllGeomPassTexturesGPU = gpuEncodeArray (sra^.sraAllGeomPassTextures),+	_sraAllGeomPassGisGPU      = gpuEncodeArray (sra^.sraAllGeomPassGis),++	_sraGeomPassMvRanges       = listArray (0, 2 * fromIntegral (sra^.sraNumGeomPasses) - 1) $+		let+			(opaqueMv, opaqueAccumLength) =+				(flip fix ((sra^.sraOpaqueGeoms), 0) $ \me (opaqueGeomPassesRemaining, accumLength) ->+					case opaqueGeomPassesRemaining of+						[] -> ([], accumLength)+						(opaqueGeomPass:remaining) ->+							let arrayLen = fromIntegral . rangeSize . bounds in+							let passLen = arrayLen (opaqueGeomPass^.gpMv) in+							first (\xs -> accumLength : passLen : xs) $ me (remaining, accumLength + passLen))+			(transparentMv, _transparentAccumLength) =+				(flip fix ((sra^.sraTransparentGeoms), opaqueAccumLength) $ \me (transparentGeomPassesRemaining, accumLength) ->+					case transparentGeomPassesRemaining of+						[] -> ([], accumLength)+						(transparentGeomPass:remaining) ->+							let arrayLen = fromIntegral . rangeSize . bounds in+							let passLen = arrayLen (transparentGeomPass^.gpMv) in+							first (\xs -> accumLength : passLen : xs) $ me (remaining, accumLength + passLen))+		in+			opaqueMv ++ transparentMv,+	_sraGeomPassTexturesRanges = listArray (0, 2 * fromIntegral (sra^.sraNumGeomPasses) - 1) $+		let+			(opaqueTextures, opaqueAccumLength) =+				(flip fix ((sra^.sraOpaqueGeoms), 0) $ \me (opaqueGeomPassesRemaining, accumLength) ->+					case opaqueGeomPassesRemaining of+						[] -> ([], accumLength)+						(opaqueGeomPass:remaining) ->+							let arrayLen = fromIntegral . rangeSize . bounds in+							let passLen = arrayLen (opaqueGeomPass^.gpTextures) in+							first (\xs -> accumLength : passLen : xs) $ me (remaining, accumLength + passLen))+			(transparentTextures, _transparentAccumLength) =+				(flip fix ((sra^.sraTransparentGeoms), opaqueAccumLength) $ \me (transparentGeomPassesRemaining, accumLength) ->+					case transparentGeomPassesRemaining of+						[] -> ([], accumLength)+						(transparentGeomPass:remaining) ->+							let arrayLen = fromIntegral . rangeSize . bounds in+							let passLen = arrayLen (transparentGeomPass^.gpTextures) in+							first (\xs -> accumLength : passLen : xs) $ me (remaining, accumLength + passLen))+		in+			opaqueTextures ++ transparentTextures,+	_sraGeomPassGisRanges      = listArray (0, 2 * fromIntegral (sra^.sraNumGeomPasses) - 1) $+		let+			(opaqueGis, opaqueAccumLength) =+				(flip fix ((sra^.sraOpaqueGeoms), 0) $ \me (opaqueGeomPassesRemaining, accumLength) ->+					case opaqueGeomPassesRemaining of+						[] -> ([], accumLength)+						(opaqueGeomPass:remaining) ->+							let arrayLen = fromIntegral . rangeSize . bounds in+							let passLen = arrayLen (opaqueGeomPass^.gpGis) in+							first (\xs -> accumLength : passLen : xs) $ me (remaining, accumLength + passLen))+			(transparentGis, _transparentAccumLength) =+				(flip fix ((sra^.sraTransparentGeoms), opaqueAccumLength) $ \me (transparentGeomPassesRemaining, accumLength) ->+					case transparentGeomPassesRemaining of+						[] -> ([], accumLength)+						(transparentGeomPass:remaining) ->+							let arrayLen = fromIntegral . rangeSize . bounds in+							let passLen = arrayLen (transparentGeomPass^.gpGis) in+							first (\xs -> accumLength : passLen : xs) $ me (remaining, accumLength + passLen))+		in+			opaqueGis ++ transparentGis,++	-- | The GPU encoded data.+	_sraGeomPassMvRangesGPU       = gpuEncodeArray (sra^.sraGeomPassMvRanges),+	_sraGeomPassTexturesRangesGPU = gpuEncodeArray (sra^.sraGeomPassTexturesRanges),+	_sraGeomPassGisRangesGPU      = gpuEncodeArray (sra^.sraGeomPassGisRanges),++	_sraGeomPassBis    = listArray'_ $ [bi | geomPasses <- [sra^.sraOpaqueGeoms, sra^.sraTransparentGeoms], geomPass <- geomPasses, bi <- return (geomPass^.gpBi)],+	_sraGeomPassBisGPU = gpuEncodeArray (sra^.sraGeomPassBis),++	_sraTexcoordsDoubleData    = genArray (0, 2 * (sol^.solTc) - 1) $ \idx -> toShaderDoubleType $ divMod idx 2 & \(ti, ridx) -> texcRelIdx ti ridx,+	_sraTexcoordsDoubleDataGPU = gpuEncodeArray (sra^.sraTexcoordsDoubleData)+}+	where+		lcoord3 :: (Integral i, Show i) => i -> Lens' (Vec3 a) a+		lcoord3 0 = x3+		lcoord3 1 = y3+		lcoord3 2 = z3+		lcoord3 x = error $ "Internal error: mkSolRenderAnalysis^.lcoord: unrecognized coord number " ++ show x ++ "."++		geomRelIdx :: Int32 -> Int32 -> Int32+		geomRelIdx gi 0    = ((sol^.solOv) ! (((sol^.solGv) ! gi)^.geomOi)^.offsVi)  -- v1 (first vertex of the triangle)+		geomRelIdx gi 1    = ((sol^.solOv) ! (((sol^.solGv) ! gi)^.geomOj)^.offsVi)  -- v2 (second vertex of the triangle)+		geomRelIdx gi 2    = ((sol^.solOv) ! (((sol^.solGv) ! gi)^.geomOk)^.offsVi)  -- v3 (third vertex of the triangle)+		geomRelIdx gi 3    = ((sol^.solOv) ! (((sol^.solGv) ! gi)^.geomOi)^.offsTi)  -- t1 (tex coords index)+		geomRelIdx gi 4    = ((sol^.solOv) ! (((sol^.solGv) ! gi)^.geomOj)^.offsTi)  -- t2+		geomRelIdx gi 5    = ((sol^.solOv) ! (((sol^.solGv) ! gi)^.geomOk)^.offsTi)  -- t3+		geomRelIdx gi 6    = ((sol^.solOv) ! (((sol^.solGv) ! gi)^.geomOi)^.offsSi)  -- s1 (side (plane) index)+		geomRelIdx gi 7    = ((sol^.solOv) ! (((sol^.solGv) ! gi)^.geomOj)^.offsSi)  -- s2+		geomRelIdx gi 8    = ((sol^.solOv) ! (((sol^.solGv) ! gi)^.geomOk)^.offsSi)  -- s3+		geomRelIdx gi ridx = error $ "Internal error: mkSolRenderAnalysis^.geomRelIdx: unrecognized ridx " ++ show ridx ++ " (gi " ++ show gi ++ ")."++		texcRelIdx :: Int32 -> Int32 -> Double+		texcRelIdx ti 0    = (((sol^.solTv) ! ti)^.texcU.x2)  -- s (texture x coord)+		texcRelIdx ti 1    = (((sol^.solTv) ! ti)^.texcU.y2)  -- t (texture y coord)+		texcRelIdx ti ridx = error $ "Internal error: mkSolRenderAnalysis^.texcRelIdx: unrecognized ridx " ++ show ridx ++ " (ti " ++ show ti ++ ")."++		lumpRelIdx :: Int32 -> Int32 -> Int32+		lumpRelIdx li 0    = ((sol^.solLv) ! li)^.lumpG0  -- g0+		lumpRelIdx li 1    = ((sol^.solLv) ! li)^.lumpGc  -- gc+		lumpRelIdx li ridx = error $ "Internal error: mkSolRenderAnalysis^.lumpRelIdx: unrecognized ridx " ++ show ridx ++ " (li " ++ show li ++ ")."++		pathDoubleRelIdx :: Int32 -> Int32 -> Double+		pathDoubleRelIdx pi_ 0    = ((sol^.solPv) ! pi_)^.pathP.x3  -- pathP.x3+		pathDoubleRelIdx pi_ 1    = ((sol^.solPv) ! pi_)^.pathP.y3  -- pathP.y3+		pathDoubleRelIdx pi_ 2    = ((sol^.solPv) ! pi_)^.pathP.z3  -- pathP.z3+		pathDoubleRelIdx pi_ ridx = error $ "Internal error: mkSolRenderAnalysis^.pathDoubleRelIdx: unrecognized ridx " ++ show ridx ++ " (pi " ++ show pi_ ++ ")."++		pathInt32RelIdx :: Int32 -> Int32 -> Int32+		pathInt32RelIdx pi_ 0    = ((sol^.solPv) ! pi_)^.pathPi  -- pathPi+		pathInt32RelIdx pi_ 1    = ((sol^.solPv) ! pi_)^.pathS   -- pathS+		pathInt32RelIdx pi_ ridx = error $ "Internal error: mkSolRenderAnalysis^.pathInt32RelIdx: unrecognized ridx " ++ show ridx ++ " (pi " ++ show pi_ ++ ")."++		bodyRelIdx :: Int32 -> Int32 -> Int32+		bodyRelIdx bi 0    = ((sol^.solBv) ! bi)^.bodyP0  -- bodyP0+		bodyRelIdx bi 1    = ((sol^.solBv) ! bi)^.bodyG0  -- bodyG0+		bodyRelIdx bi 2    = ((sol^.solBv) ! bi)^.bodyGc  -- bodyGc+		bodyRelIdx bi ridx = error $ "Internal error: mkSolRenderAnalysis^.bodyRelIdx: unrecognized ridx " ++ show ridx ++ " (bi " ++ show bi ++ ")."++		-- | It'd be nice to be able to render the whole scene in a single+		-- pass, but since our shader only handles 16 textures at once, split+		-- up mtrl (mv) textures into chunks of up to 16, and then for each chunk+		-- of mtrls, take the portion of all of the scene we render that uses a+		-- texture material in that chunk.  It partitions the scene (i.e. it+		-- partitions the geom array gv) into partitions each of which only use+		-- up to 16 textures.+		--+		-- That's the purpose of this function.  Partition into partitions+		-- (each partition is a GeomPass).  Each geom is a textured triangle to+		-- draw, BTW.  Each GeomPass is a partition as we described.+		--+		-- Finally, the caller first takes all partitions on all+		-- non-transparent geometry, then take all partitions on all+		-- transparent geometry (i.e. that supports an alpha test (technically+		-- could still be opaque but just has alpha / transparency enabled)).+		passGeom :: Integer -> Bool -> (Int32, Body) -> [GeomPass]+		passGeom maxTextures transparent (bi, b) = geomPasses+			where+				indirection :: Int32 -> Int32+				indirection idx = (sol^.solIv) ! idx++				wholeGpGisDirect = map indirection [b^.bodyG0 .. b^.bodyG0 + b^.bodyGc - 1]+				wholeGpGisLumps = map indirection [r | li <- [b^.bodyL0 .. b^.bodyL0 + b^.bodyLc - 1], l <- return $ ((sol^.solLv) ! li), gi <- [l^.lumpG0 .. l^.lumpG0 + l^.lumpGc - 1], r <- return gi]++				-- First make a single GeomPass - a single array structure that we will later split up by 16.+				wholeGpGis = wholeGpGisDirect ++ wholeGpGisLumps+				wholeGpGisTransparent = flip filter wholeGpGis $ \gi ->+					let g = (sol^.solGv) ! gi in let mi = g^.geomMi in let mtrl = (sol^.solMv) ! mi in+					(((mtrl^.mtrlFl) .&. mtrlFlagAlphaTest) /= 0) == transparent+				(wholeGpMvTextures, miToTexture) = flip runState M.empty . fmap concatFirst . forM wholeGpGisTransparent $ \gi -> let g = (sol^.solGv) ! gi in let mi = g^.geomMi in+					gets (M.lookup mi) >>= \midx -> case midx of+						Just idx -> return ([], idx)+						Nothing -> do+							idxs <- get+							let nextIdx = fromIntegral $ M.size idxs+							put $ M.insert mi nextIdx idxs+							return ([mi], nextIdx)+				(wholeGpMv, _wholeGpTextures) = split wholeGpMvTextures++				-- (We could pre-process the whole textures list, but it's+				-- convenient to process the index list at the same time that we+				-- chunk it up.)+				--wholeGpTextures' = map (`mod` maxTextures) wholeGpTextures++				-- Split up unique materials mv into pass chunks of 16, and+				-- split up gv and mv indices where the gv/mv pair points to a+				-- mtrl represented in the current pass.  (gv/mv pairings+				-- should be preserved, not end up between different partitions,+				-- since they make up an aggregate structure.)+				gpMvPasses          = chunksOf maxTextures wholeGpMv+				gpGisTexturesPasses = flip map gpMvPasses $ \mvPass ->+					let gisPass = flip filter wholeGpGisTransparent $ \gi -> (((sol^.solGv) ! gi)^.geomMi) `elem` mvPass in+					let err mi = error $ "Internal error: mkSolRenderAnalysis^.geomPasses: we thought we were tracking mtrl texture indices, but we couldn't find a texture index for mtrl i " ++ show mi ++ "." in+					flip map gisPass $ \gi -> (gi, let g = (sol^.solGv) ! gi in let mi = g^.geomMi in fi $ (fromMaybe (err mi) $ M.lookup mi miToTexture) `mod` maxTextures)+				(fi :: Integer -> Int32) = fromIntegral+				(gpGisPasses, gpTexturesPasses) = split . map split $ gpGisTexturesPasses++				listArray' xs = listArray (0, fromIntegral (length xs) - 1) xs++				gpGisPasses'      = map listArray' gpGisPasses+				gpMvPasses'       = map listArray' gpMvPasses+				gpTexturesPasses' = map listArray' gpTexturesPasses++				geomPasses = flip map (zip3 gpGisPasses' gpMvPasses' gpTexturesPasses') $+					\(gpGisPass, gpMvPass, gpTexturesPass) -> fix $ \gp -> GeomPass {+						_gpBi = bi,++						_gpMv = gpMvPass,++						_gpTextures    = fromIntegral <$> gpTexturesPass,+						_gpTexturesGPU = gpuEncodeArray (gp^.gpTextures),++						_gpGis    = gpGisPass,+						_gpGisGPU = gpuEncodeArray (gp^.gpGis)+					}++		listArray'_ xs = listArray (0, genericLength xs - 1) xs++{-+-- | Pseudo-lens, probably, because the setter can't _add_ to adjacents.+spaLumpGetVertexAdjacents :: Lens' SolPhysicsAnalysis (Int32 -> Int32 -> S.Set Int32)+spaLumpGetVertexAdjacents = lens getter (flip setter)+	where+		getter :: SolPhysicsAnalysis -> (Int32 -> Int32 -> S.Set Int32)+		getter (Vec2 x y) = getSpaLumpGetVertexAdjacents+		setter :: (Int32 -> Int32 -> S.Set Int32) -> SolPhysicsAnalysis -> SolPhysicsAnalysis+		setter = TODO+-}++getSpaLumpGetVertexAdjacents :: SolPhysicsAnalysis -> (Int32 -> Int32 -> S.Set Int32)+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 {+	_spaLumpOutwardsSides                     = (^._1) <$> lumpSidesData spa,+	_spaLumpOutwardsSidesNumNegatedNormals    = (^._2) <$> lumpSidesData spa,+	_spaLumpOutwardsSidesNumNotNegatedNormals = (^._3) <$> lumpSidesData spa,++	_spaLumpAverageVertex = lumpAverageVertex spa,++	_spaLumpVertexAdjacents    = lumpVertexAdjacents spa,+	{-+	_spaLumpGetVertexAdjacents = lumpGetVertexAdjacents spa,+	-}+	_spaLumpPlanes             = lumpPlanes spa+}+	where+		indirection :: Int32 -> Int32+		indirection idx = (sol^.solIv) ! idx++		lumpAverageVertex :: SolPhysicsAnalysis -> M.Map Int32 (Vec3 Double)+		lumpAverageVertex _spa = M.fromList . flip map [0..sol^.solLc - 1] $ \li ->+			let lump = (sol^.solLv) ! li in+			let vis = indirection <$> [lump^.lumpV0..lump^.lumpV0 + lump^.lumpVc - 1] in+			let vs = ((sol^.solVv) !) <$> vis in+			let vsum = sum ((^.vertP) <$> vs) in+			let vmean = (1/(fromIntegral $ lump^.lumpVc)) `sv3` vsum in+			(li, vmean)++		-- | Simply look at an arbitrary point in the convex lump to see if a+		-- given normal should be negated to make the point fall behind the+		-- plane.+		lumpSidesData :: SolPhysicsAnalysis -> M.Map Int32 ([Plane3 Double], Integer, Integer)+		lumpSidesData spa = M.fromList . flip map [0..sol^.solLc - 1] $ \li ->+			let averageVertexErrMsg = "Internal error: mkSolPhysicsAnalysis: finding lump sides data for lump without average vertex for li " ++ (show li) ++ "." in+			let averageVertex = flip M.lookup (spa^.spaLumpAverageVertex) li `morElse` error averageVertexErrMsg in+			let lump = (sol^.solLv) ! li in+			let sis = indirection <$> [lump^.lumpS0..lump^.lumpS0 + lump^.lumpSc - 1] in+			let sides = ((sol^.solSv) !) <$> sis in+			let planes = flip map sides $ \side -> normalPlane3 (side^.sideN) (side^.sideD) in+			let backwardsPlanes = flip map planes $ \p -> not $ plane3PointDistance p averageVertex <= 0 in+			let numNeg = genericLength . filter id  $ backwardsPlanes in+			let numId  = genericLength . filter not $ backwardsPlanes in+			let planes' = flip map (zip planes backwardsPlanes) . uncurry $ \p n -> if' (not n) (p) (negatePlaneOrientation p) in+			(li, (planes', numNeg, numId))++		lumpVertexAdjacents :: SolPhysicsAnalysis -> M.Map Int32 (M.Map Int32 (S.Set Int32))+		lumpVertexAdjacents _spa = M.fromList . flip map [0..sol^.solLc - 1] $ \li ->+			let lump = (sol^.solLv) ! li in+			let eis = indirection <$> [lump^.lumpE0..lump^.lumpE0 + lump^.lumpEc - 1] in+			let _vis = indirection <$> [lump^.lumpV0..lump^.lumpV0 + lump^.lumpVc - 1] in+			let edges = ((sol^.solEv) !) <$> eis in+			(\reduce -> (li, foldr reduce M.empty edges)) $ \edge adjacents ->+			let union_ = (\new_value old_value -> new_value `S.union` old_value) in  -- (left-biased, not that it matters here.)+			M.insertWith union_ (edge^.edgeVi) (S.singleton $ edge^.edgeVj) .+			M.insertWith union_ (edge^.edgeVj) (S.singleton $ edge^.edgeVi) $+			adjacents++		{-+		lumpGetVertexAdjacents :: SolPhysicsAnalysis -> (Int32 -> Int32 -> S.Set Int32)+		lumpGetVertexAdjacents spa = \li vi -> (M.lookup li (spa^.spaLumpVertexAdjacents) >>= M.lookup vi) `morElse` S.empty+		-}++		-- | Manually constructed set of planes for each lump.+		-- TODO: optimize this better, so it's efficient, at least more than+		-- this.+		lumpPlanes :: SolPhysicsAnalysis -> M.Map Int32 [Plane3 Double]+		lumpPlanes spa = M.fromList . flip map [0..sol^.solLc - 1] $ \li ->+			let lump = (sol^.solLv) ! li in+			let vis = indirection <$> [lump^.lumpV0..lump^.lumpV0 + lump^.lumpVc - 1] in++			-- Get a bunch of planes; we'll have a lot of duplicates (and+			-- probably a lot of needless extra computation.)+			let planesStart = do+				-- For every 3 adjacent points,+				vi <- vis+				vj <- toList $ (getSpaLumpGetVertexAdjacents spa) li vi+				vk <- toList $ (getSpaLumpGetVertexAdjacents spa) li vj+				guard $ vk /= vj && vk /= vi++				let viv = (sol^.solVv) ! vi+				let vjv = (sol^.solVv) ! vj+				let vkv = (sol^.solVv) ! vk++				let (iv :: Vec3 Double) = viv^.vertP+				let (jv :: Vec3 Double) = vjv^.vertP+				let (kv :: Vec3 Double) = vkv^.vertP++				-- Get the plane they're on.+				let (abc_ :: Vec3 Double) = (kv - jv) `vx3` (iv - jv)  -- (CCW order so it screws outward from the body, but we'll re-orient anyway.)+				let abc = v3normalize abc_+				let v = jv++				let plane = normalizePlane3 v abc++				let r = plane+				return $ r in+			-- De-duplicate the planes.+			let planesDedup = nubBy eqPlane3PointsOnly $ planesStart in++			-- Now orient the planes, so that the normal is pointing outwards+			-- from the convex lump.  That is, negate the normal orientation of+			-- the plane if it's pointing inwards instead of outwards.+			let planesUnoriented = planesDedup in+			let averageVertexErrMsg = "Internal error: mkSolPhysicsAnalysis: finding lump sides data for lump without average vertex for li " ++ (show li) ++ "." in+			let averageVertex = flip M.lookup (spa^.spaLumpAverageVertex) li `morElse` error averageVertexErrMsg in+			let backwardsPlanes = flip map planesUnoriented $ \p -> not $ plane3PointDistance p averageVertex <= 0 in+			let (_numNeg :: Integer) = genericLength . filter id  $ backwardsPlanes in+			let (_numId  :: Integer) = genericLength . filter not $ backwardsPlanes in+			let planesOriented = flip map (zip planesUnoriented backwardsPlanes) . uncurry $ \p n -> if' (not n) (p) (negatePlaneOrientation p) in++			-- Return the planes.+			(li, planesOriented)
+ Immutaball/Share/Level/Analysis/LowLevel.hs view
@@ -0,0 +1,71 @@+{-# 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 #-}++-- Game.hs.++{-# LANGUAGE Haskell2010 #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | The part of Level.Analysis that uses low-level memory management to interface with the GPU.+module Immutaball.Share.Level.Analysis.LowLevel+	(+		gpuEncodeArray+	) where++{-+-- Prelude imports.+import Prelude ()+import Immutaball.Prelude++-- base imports.+import Data.Int+import Foreign.C.Types+import Foreign.Ptr+import Foreign.Storable++-- external imports.+import Data.Array.IArray+import Data.Array.Storable+import qualified Data.Array.Unsafe+import qualified Data.ByteString as BS++-- internal (local) imports.+import Immutaball.Share.ImmutaballIO.GLIO++-- Low-level imports.+import System.IO.Unsafe (unsafePerformIO)+-}++-- Prelude imports.+import Prelude ()+--import Immutaball.Prelude++-- base imports.+import Data.Int+import Foreign.Storable++-- external imports.+import Data.Array.IArray++-- internal (local) imports.+import Immutaball.Share.ImmutaballIO.GLIO+import qualified Immutaball.Share.Video.LowLevel++{-+gpuEncodeArray :: forall a. (Storable a) => Array Int32 a -> GLData+gpuEncodeArray array_ = unsafePerformIO $ do+	(storableArray :: StorableArray Int32 a) <- Data.Array.Unsafe.unsafeThaw array_+	bs <- withStorableArray storableArray $ \(ptr :: Ptr a) -> do+		let (bsPtr :: Ptr CChar) = castPtr ptr+		let (numElems :: Int) = rangeSize . bounds $ array_+		let (bsLen :: Int) = numElems * sizeOf ((array_ ! 0)  :: a)+		bs <- BS.packCStringLen (bsPtr, bsLen)+		return bs+	let data_ = bsToGLData bs+	return $ data_+-}++-- | This has been moved to Video.LowLevel.+gpuEncodeArray :: forall a. (Storable a) => Array Int32 a -> GLData+gpuEncodeArray = Immutaball.Share.Video.LowLevel.gpuEncodeArray
+ Immutaball/Share/Level/Attributes.hs view
@@ -0,0 +1,121 @@+{-# 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 #-}++-- Game.hs.++{-# LANGUAGE Haskell2010 #-}+{-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-}++module Immutaball.Share.Level.Attributes+	(+		SolAttributes(..), saAttributes, saMessage, saSong, saShot, saGoal,+			saTime, saTimeHs, saFastUnlockHs, saCoinHs, saVersionStr,+			saVersionNum, saAuthor, saBonus,+		mkSolAttributes+	) where++import Prelude ()+import Immutaball.Prelude++import Data.Maybe+import Data.Function hiding (id, (.))+import Data.Word+import Foreign.C.Types++import Control.Lens+import Data.Array.IArray+import qualified Data.Map as M++import Immutaball.Share.Level.Base+import Immutaball.Share.Utils++data SolAttributes = SolAttributes {+	-- | Level attributes.+	_saAttributes :: M.Map String String,++	-- | Level message.+	_saMessage      :: String,+	-- | Level song / track.+	_saSong         :: String,+	-- | Screenshot of the level.+	_saShot         :: String,+	-- | Coins needed to unlock the goal.+	_saGoal         :: Integer,+	-- | Time available in this level.+	_saTime         :: Integer,+	-- | Hard, easy, medium.  Best times.+	_saTimeHs       :: (Integer, Integer, Integer),+	-- | Hard, easy, medium.  Fast unlock (best times after unlocking goal).+	_saFastUnlockHs :: (Integer, Integer, Integer),+	-- | Hard, easy, medium.  Most coins.+	_saCoinHs       :: (Integer, Integer, Integer),++	_saVersionStr :: String,+	_saVersionNum :: Integer,+	_saAuthor     :: String,+	-- | Is this a bonus level?+	_saBonus      :: Bool+}+	deriving (Eq, Ord, Show)+makeLenses ''SolAttributes++mkSolAttributes :: Sol -> SolAttributes+mkSolAttributes sol = fix $ \sa -> SolAttributes {+	_saAttributes = M.fromList $ do+		d <- elems (sol^.solDv)+		(ki, vi) <- return (d^.dictAi, d^.dictAj)+		let k = (\f -> fix f 0 "") $ \me idx reversed_ ->+			let (cc :: CChar) = (sol^.solAv)!(ki+idx) in+			let (cb :: Word8) = fromIntegral cc in+			let (c :: Char) = asciiChar8 cb in+			if' (cc == 0) (reverse reversed_) $+			me (idx+1) (c:reversed_)+		let v = (\f -> fix f 0 "") $ \me idx reversed_ ->+			let (cc :: CChar) = (sol^.solAv)!(vi+idx) in+			let (cb :: Word8) = fromIntegral cc in+			let (c :: Char) = asciiChar8 cb in+			if' (cc == 0) (reverse reversed_) $+			me (idx+1) (c:reversed_)+		let r = (k, v)+		return r,++	_saMessage = M.lookup "message" (sa^.saAttributes) & fromMaybe "",+	_saSong    = M.lookup "song"    (sa^.saAttributes) & fromMaybe "",+	_saShot    = M.lookup "shot"    (sa^.saAttributes) & fromMaybe "",+	_saGoal    = M.lookup "goal"    (sa^.saAttributes) >>= parseInteger & fromMaybe 0,+	_saTime    = M.lookup "time"    (sa^.saAttributes) >>= parseInteger & fromMaybe 0,+	_saTimeHs  =+		let (hard,    afterHard)   = M.lookup "time_hs" (sa^.saAttributes) >>= parseIntegerMore & fromMaybe (sa^.saTime, "") in+		let (medium,  afterMedium) = parseIntegerMore afterHard                                 & fromMaybe (sa^.saTime, "") in+		let (easy,   _afterEasy)   = parseIntegerMore afterMedium                               & fromMaybe (sa^.saTime, "") in+		(hard, medium, easy),+	_saFastUnlockHs  =+		let (hard,    afterHard)   = M.lookup "goal_hs" (sa^.saAttributes) >>= parseIntegerMore & fromMaybe (sa^.saTime, "") in+		let (medium,  afterMedium) = parseIntegerMore afterHard                                 & fromMaybe (sa^.saTime, "") in+		let (easy,   _afterEasy)   = parseIntegerMore afterMedium                               & fromMaybe (sa^.saTime, "") in+		(hard, medium, easy),+	_saCoinHs  =+		let (hard,    afterHard)   = M.lookup "coin_hs" (sa^.saAttributes) >>= parseIntegerMore & fromMaybe (sa^.saGoal, "") in+		let (medium,  afterMedium) = parseIntegerMore afterHard                                 & fromMaybe (sa^.saGoal, "") in+		let (easy,   _afterEasy)   = parseIntegerMore afterMedium                               & fromMaybe (sa^.saGoal, "") in+		(hard, medium, easy),++	_saVersionStr = M.lookup "version" (sa^.saAttributes) & fromMaybe "",+	_saVersionNum = let (versionNum, _afterVersionNum) = parseIntegerMore (sa^.saVersionStr) & fromMaybe (0, "") in versionNum,+	_saAuthor     = M.lookup "author" (sa^.saAttributes) & fromMaybe "",+	_saBonus      = (M.lookup "bonus" (sa^.saAttributes) >>= parseInteger & fromMaybe 0) /= 0+}+	where+		asciiChar8 :: Word8 -> Char+		asciiChar8 = toEnum . fromEnum++		parseInteger :: String -> Maybe Integer+		parseInteger str = case (reads str :: [(Integer, String)]) of+			([(val, "")]) -> Just val+			_             -> Nothing++		parseIntegerMore :: String -> Maybe (Integer, String)+		parseIntegerMore str = case (reads str :: [(Integer, String)]) of+			([(val, rest)]) -> Just (val, rest)+			_               -> Nothing
+ Immutaball/Share/Level/Base.hs view
@@ -0,0 +1,2051 @@+{-# 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/Base.hs.++{-# LANGUAGE Haskell2010 #-}+{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, NondecreasingIndentation #-}++module Immutaball.Share.Level.Base+	(+		-- * sol+		solPathMax,+		solMagicConstant,+		solVersionCurr,+		solVersion2024_04,+		pathFlagOriented,+		pathFlagParented,+		mtrlFlagAlphaTest,+		lumpFlagDetail,+		Mtrl(..), mtrlD, mtrlA, mtrlS, mtrlE, mtrlH, mtrlAngle, mtrlFl, mtrlF,+			mtrlAlphaFunc, mtrlAlphaRef,+		Vert(..), vertP,+		Edge(..), edgeVi, edgeVj,+		Side(..), sideN, sideD,+		Texc(..), texcU,+		Offs(..), offsTi, offsSi, offsVi,+		Geom(..), geomMi, geomOi, geomOj, geomOk,+		Lump(..), lumpFl, lumpV0, lumpVc, lumpE0, lumpEc, lumpG0, lumpGc,+			lumpS0, lumpSc,+		Node(..), nodeSi, nodeNi, nodeNj, nodeL0, nodeLc,+		Path(..), pathP, pathE, pathT, pathTm, pathPi, pathF, pathS, pathFl,+			pathP0, pathP1,+		Body(..), bodyP0, bodyP1, bodyNi, bodyL0, bodyLc, bodyG0, bodyGc,+		Item(..), itemP, itemT, itemN, itemP0, itemP1,+		Goal(..), goalP, goalR, goalP0, goalP1,+		Jump(..), jumpP, jumpQ, jumpR, jumpP0, jumpP1,+		Swch(..), swchP, swchR, swchPi, swchT, swchTm, swchF, swchI, swchP0, swchP1,+		Bill(..), billFl, billMi, billT, billD, billW, billH, billRx, billRy,+			billRz, billP, billP0, billP1,+		Ball(..), ballP, ballR,+		View(..), viewP, viewQ,+		Dict(..), dictAi, dictAj,+		Sol(..), solMagic, solVersion, solAc, solDc, solMc, solVc, solEc,+			solSc, solTc, solOc, solGc, solLc, solNc, solPc, solBc, solHc,+			solZc, solJc, solXc, solRc, solUc, solWc, solIc, solAv, solDv,+			solMv, solVv, solEv, solSv, solTv, solOv, solGv, solLv, solNv,+			solPv, solBv, solHv, solZv, solJv, solXv, solRv, solUv, solWv,+			solIv,+		LevelIB,+		emptySol,++		-- * Optional low-level storable provisions (we don't use these)+		peeki32Native,+		peeki32BE,+		peeki32LE,+		peekf32dLE,+		peekn,+		peeknWith,+		peekCString,+		pokei32Native,+		pokei32BE,+		pokei32LE,+		pokef32dLE,+		poken,+		pokenWith,+		pokeCString,+		asType,+		sizeOfMtrl,+		sizeOfMtrlMin,+		sizeOfMtrlMax,+		sizeOfExistingMtrl,+		sizeOfPath,+		sizeOfPathMin,+		sizeOfPathMax,+		sizeOfExistingPath,+		sizeOfEmptySol,+		sizeOfExistingSolMin,+		sizeOfExistingSolMax,+		sizeOfExistingSol,+		peekSol,+		peekSolLengths,+		pokeSol+	) where++import Prelude ()+import Immutaball.Prelude++import Control.Arrow+import Control.Monad+import Control.Monad.Fix+import Data.Bits+import Data.Coerce+--import Data.Function hiding (id, (.))+import Data.Int+import Data.Word+import Foreign.C.Types+import Foreign.ForeignPtr+import Foreign.Ptr+import Foreign.Storable++import Control.Lens+import Control.Monad.Trans.Class+import Control.Monad.Trans.State+import Data.Array+import Data.Array.IO+import Data.Array.IArray as IA+--import Data.Array.MArray as MA+--import Data.Array.Unboxed++import Immutaball.Share.Math+import Immutaball.Share.Utils++-- * sol++solPathMax :: Int+solPathMax = 64++solMagicConstant :: Int32+solMagicConstant = 0x4C4F53AF  -- LE encoding of AF 'S' 'O' 'L'.++solVersionCurr :: Int32+solVersionCurr = solVersion2024_04++solVersion2024_04 :: Int32+solVersion2024_04 = 9++pathFlagOriented :: Int32+pathFlagOriented = 1++pathFlagParented :: Int32+pathFlagParented = 2++mtrlFlagAlphaTest :: Int32+mtrlFlagAlphaTest = 1 `shiftL` 9++lumpFlagDetail :: Int32+lumpFlagDetail = 1++data Mtrl = Mtrl {+	-- | Diffuse color.+	_mtrlD :: Vec4 Double,+	-- | Ambient color.+	_mtrlA :: Vec4 Double,+	-- | Specular color.+	_mtrlS :: Vec4 Double,+	-- | Emmission color.+	_mtrlE :: Vec4 Double,+	-- | Specular exponent.+	_mtrlH :: Double,++	_mtrlAngle :: Double,++	-- | Material flags.+	_mtrlFl :: Int32,++	-- | Texture file name.+	_mtrlF :: String,++	-- | Comparison function.+	_mtrlAlphaFunc :: Int32,+	_mtrlAlphaRef :: Double+}+	deriving (Eq, Ord, Show)+makeLenses ''Mtrl++data Vert = Vert {+	-- | Vertex position.+	_vertP :: Vec3 Double+}+	deriving (Eq, Ord, Show)+makeLenses ''Vert++data Edge = Edge {+	_edgeVi :: Int32,+	_edgeVj :: Int32+}+	deriving (Eq, Ord, Show)+makeLenses ''Edge++data Side = Side {+	-- | Plane normal vector.+	_sideN :: Vec3 Double,+	-- | Distance from origin.+	_sideD :: Double+}+	deriving (Eq, Ord, Show)+makeLenses ''Side++data Texc = Texc {+	-- | Texture coordinates.+	_texcU :: Vec2 Double+}+	deriving (Eq, Ord, Show)+makeLenses ''Texc++data Offs = Offs {+	-- | Texcoords (Texc) index, side (plane) index, and vertex index, for this vertex.+	-- translation and scale.  Neverball sols ignore texture angle.+	_offsTi :: Int32,+	_offsSi :: Int32,+	-- | Vertex.+	_offsVi :: Int32+}+	deriving (Eq, Ord, Show)+makeLenses ''Offs++data Geom = Geom {+	-- | Material index (base texture).+	_geomMi :: Int32,+	-- | Triangle vertex 1 (Offs).+	_geomOi :: Int32,+	-- | Triangle vertex 2.+	_geomOj :: Int32,+	-- | Triangle vertex 3.+	_geomOk :: Int32+}+	deriving (Eq, Ord, Show)+makeLenses ''Geom++data Lump = Lump {+	-- | Lump flags.  In particular lumpFlagDetail == 1.+	_lumpFl :: Int32,+	_lumpV0 :: Int32,+	_lumpVc :: Int32,+	_lumpE0 :: Int32,+	_lumpEc :: Int32,+	_lumpG0 :: Int32,+	_lumpGc :: Int32,+	_lumpS0 :: Int32,+	_lumpSc :: Int32+}+	deriving (Eq, Ord, Show)+makeLenses ''Lump++-- | Three-part plane partitioning.+--+-- Normally the lumps are sorted while the nodes are being created.  Each+-- non-leaf node has 3 ranges in the sorted lumps, each range represented by a+-- Each node corresponds to 1) the range of all lumps in front of the plane+-- (ni), 2) all lumps on the plane (the node's direct l0 and lc range), and 3)+-- all lumps behind the plane (nj).+--+-- At 8 or so or fewer nodes, the base case is reached with a Nothing ni and nj+-- and si (represented by -1), and l0 and lc still represents the range of lumps.+--+-- Thus a node is like a node in a binary tree with its own unique range / span+-- of the lumps, and the nodes uniquely and comprehensively span the range of+-- lumps.+--+-- Now each body is a collection of lumps that follows the same path; it's like+-- a set of lumps.  Each body has a BSP partitioning with Nodes.+data Node = Node {+	_nodeSi :: Int32,+	_nodeNi :: Int32,+	_nodeNj :: Int32,+	_nodeL0 :: Int32,+	_nodeLc :: Int32+}+	deriving (Eq, Ord, Show)+makeLenses ''Node++data Path = Path {+	-- | Starting position.+	_pathP :: Vec3 Double,+	-- | Orientation (quaternion).+	_pathE :: Vec4 Double,+	-- | Travel time.+	_pathT :: Double,+	-- | Milliseconds.+	_pathTm :: Int32,++	-- | Next path.+	_pathPi :: Int32,+	-- | Enable flag.+	_pathF :: Int32,+	-- | Smooth flag.+	_pathS :: Int32,++	-- | Flags.+	_pathFl :: Int32,++	_pathP0 :: Int32,+	_pathP1 :: Int32+}+	deriving (Eq, Ord, Show)+makeLenses ''Path++data Body = Body {+	-- | Translation path.+	_bodyP0 :: Int32,+	-- | Rotation path.+	_bodyP1 :: Int32,++	_bodyNi :: Int32,+	_bodyL0 :: Int32,+	_bodyLc :: Int32,+	_bodyG0 :: Int32,+	_bodyGc :: Int32+}+	deriving (Eq, Ord, Show)+makeLenses ''Body++data Item = Item {+	-- | Position.+	_itemP :: Vec3 Double,+	-- | Type.+	_itemT :: Int32,+	-- | Value.+	_itemN :: Int32,++	-- | Translation path.+	_itemP0 :: Int32,+	-- | Rotation path.+	_itemP1 :: Int32+}+	deriving (Eq, Ord, Show)+makeLenses ''Item++data Goal = Goal {+	-- | Position.+	_goalP :: Vec3 Double,+	-- | Radius.+	_goalR :: Double,++	-- | Translation path.+	_goalP0 :: Int32,+	-- | Rotation path.+	_goalP1 :: Int32+}+	deriving (Eq, Ord, Show)+makeLenses ''Goal++data Jump = Jump {+	-- | Position.+	_jumpP :: Vec3 Double,+	-- | Target position.+	_jumpQ :: Vec3 Double,+	-- | Radius.+	_jumpR :: Double,++	-- | Translation path.+	_jumpP0 :: Int32,+	-- | Rotation path.+	_jumpP1 :: Int32+}+	deriving (Eq, Ord, Show)+makeLenses ''Jump++data Swch = Swch {+	-- | Position.+	_swchP :: Vec3 Double,+	-- | Radius.+	_swchR :: Double,+	-- | The activated path.+	_swchPi :: Int32,++	-- | Default timer.+	_swchT :: Double,+	-- | Milliseconds.+	_swchTm :: Int32,+	-- | Default state.+	_swchF :: Int32,+	-- | Is invisible?+	_swchI :: Int32,++	-- | Translation path.+	_swchP0 :: Int32,+	-- | Rotation path.+	_swchP1 :: Int32+}+	deriving (Eq, Ord, Show)+makeLenses ''Swch++data Bill = Bill {+	_billFl :: Int32,+	_billMi :: Int32,+	-- | Repeat time interval.+	_billT :: Double,+	-- | Distance.+	_billD :: Double,++	-- | Width coefficients.+	_billW :: Vec3 Double,+	-- | Height coefficients.+	_billH :: Vec3 Double,++	-- | X rotation coefficients.+	_billRx :: Vec3 Double,+	-- | Y rotation coefficients.+	_billRy :: Vec3 Double,+	-- | Z rotation coefficients.+	_billRz :: Vec3 Double,++	_billP :: Vec3 Double,++	-- | Translation path.+	_billP0 :: Int32,+	-- | Rotation path.+	_billP1 :: Int32+}+	deriving (Eq, Ord, Show)+makeLenses ''Bill++data Ball = Ball {+	_ballP :: Vec3 Double,+	_ballR :: Double+}+	deriving (Eq, Ord, Show)+makeLenses ''Ball++data View = View {+	_viewP :: Vec3 Double,+	_viewQ :: Vec3 Double+}+	deriving (Eq, Ord, Show)+makeLenses ''View++data Dict = Dict {+	_dictAi :: Int32,+	_dictAj :: Int32+}+	deriving (Eq, Ord, Show)+makeLenses ''Dict++-- | The level format: .sol.+--+-- Uses little-endian format.+--+-- Also encoded as floats, but we read into doubles.+--+-- The Storable instance does not follow the sizeOf laws of not accessing its+-- argument, but is still useful for reading and writing when combined with+-- validation.  peekSol and pokeSol offer more pure implementations.+--+-- Note that Mtrl, Path, and Swch have irregular serializers, and Mtrl and Path+-- is variable-width.  The sizes by default are the conservative max sizes.+data Sol = Sol {+	_solMagic   :: Int32,+	_solVersion :: Int32,++	_solAc :: Int32,+	_solDc :: Int32,+	_solMc :: Int32,+	_solVc :: Int32,+	_solEc :: Int32,+	_solSc :: Int32,+	_solTc :: Int32,+	_solOc :: Int32,+	_solGc :: Int32,+	_solLc :: Int32,+	_solNc :: Int32,+	_solPc :: Int32,+	_solBc :: Int32,+	_solHc :: Int32,+	_solZc :: Int32,+	_solJc :: Int32,+	_solXc :: Int32,+	_solRc :: Int32,+	_solUc :: Int32,+	_solWc :: Int32,+	_solIc :: Int32,++	_solAv :: Array Int32 CChar,+	_solDv :: Array Int32 Dict,+	_solMv :: Array Int32 Mtrl,+	_solVv :: Array Int32 Vert,+	_solEv :: Array Int32 Edge,+	_solSv :: Array Int32 Side,+	_solTv :: Array Int32 Texc,+	_solOv :: Array Int32 Offs,+	_solGv :: Array Int32 Geom,+	_solLv :: Array Int32 Lump,+	_solNv :: Array Int32 Node,+	_solPv :: Array Int32 Path,+	_solBv :: Array Int32 Body,+	_solHv :: Array Int32 Item,+	_solZv :: Array Int32 Goal,+	_solJv :: Array Int32 Jump,+	_solXv :: Array Int32 Swch,+	_solRv :: Array Int32 Bill,+	_solUv :: Array Int32 Ball,+	_solWv :: Array Int32 View,+	_solIv :: Array Int32 Int32+}+	deriving (Eq, Ord, Show)+makeLenses ''Sol++type LevelIB = Sol++emptySol :: Sol+emptySol =+	(Sol+		solMagicConstant solVersionCurr+		0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0+		a a a a a a a a a a a a a a a a a a a a a+	)+	where+		a :: (Storable a) => Array Int32 a+		a = IA.listArray (0, -1) []++-- * Optional low-level storable provisions (we don't use these)++instance Storable Sol where+	sizeOf = sizeOfEmptySol++	alignment+		~(Sol+			magic version+			ac dc mc vc ec sc tc oc gc lc nc pc bc hc zc jc xc rc uc wc ic+			--av dv mv vv ev sv tv ov gv lv nv pv bv hv zv jv xv rv uv wv iv+			_  _  _  _  _  _  _  _  _  _  _  _  _  _  _  _  _  _  _  _  _+		) = max 1 . maximum $+			[+				alignment magic,+				alignment version,++				alignment ac,+				alignment dc,+				alignment mc,+				alignment vc,+				alignment ec,+				alignment sc,+				alignment tc,+				alignment oc,+				alignment gc,+				alignment lc,+				alignment nc,+				alignment pc,+				alignment bc,+				alignment hc,+				alignment zc,+				alignment jc,+				alignment xc,+				alignment rc,+				alignment uc,+				alignment wc,+				alignment ic,++				alignment (error "Internal error: alignment Sol: alignment accessed its argument!"  :: CChar),+				alignment (error "Internal error: alignment Sol: alignment accessed its argument!"  :: Dict ),+				alignment (error "Internal error: alignment Sol: alignment accessed its argument!"  :: Mtrl ),+				alignment (error "Internal error: alignment Sol: alignment accessed its argument!"  :: Vert ),+				alignment (error "Internal error: alignment Sol: alignment accessed its argument!"  :: Edge ),+				alignment (error "Internal error: alignment Sol: alignment accessed its argument!"  :: Side ),+				alignment (error "Internal error: alignment Sol: alignment accessed its argument!"  :: Texc ),+				alignment (error "Internal error: alignment Sol: alignment accessed its argument!"  :: Offs ),+				alignment (error "Internal error: alignment Sol: alignment accessed its argument!"  :: Geom ),+				alignment (error "Internal error: alignment Sol: alignment accessed its argument!"  :: Lump ),+				alignment (error "Internal error: alignment Sol: alignment accessed its argument!"  :: Node ),+				alignment (error "Internal error: alignment Sol: alignment accessed its argument!"  :: Path ),+				alignment (error "Internal error: alignment Sol: alignment accessed its argument!"  :: Body ),+				alignment (error "Internal error: alignment Sol: alignment accessed its argument!"  :: Item ),+				alignment (error "Internal error: alignment Sol: alignment accessed its argument!"  :: Goal ),+				alignment (error "Internal error: alignment Sol: alignment accessed its argument!"  :: Jump ),+				alignment (error "Internal error: alignment Sol: alignment accessed its argument!"  :: Swch ),+				alignment (error "Internal error: alignment Sol: alignment accessed its argument!"  :: Bill ),+				alignment (error "Internal error: alignment Sol: alignment accessed its argument!"  :: Ball ),+				alignment (error "Internal error: alignment Sol: alignment accessed its argument!"  :: View ),+				alignment (error "Internal error: alignment Sol: alignment accessed its argument!"  :: Int32)+			]++	peek = peekSol+	poke = pokeSol++sizeOfMtrl :: Mtrl -> Int+sizeOfMtrl = sizeOfMtrlMax++sizeOfMtrlMin :: Mtrl -> Int+sizeOfMtrlMin+	~(Mtrl+		_d _a _s _e _h _angle fl _f _alphaFunc _alphaRef+	) = sum $+		[+			sizeOf x' * 4,+			sizeOf x' * 4,+			sizeOf x' * 4,+			sizeOf x' * 4,+			sizeOf x',+			--sizeOf x',+			sizeOf fl,+			solPathMax+			--sizeOf alphaFunc,+			--sizeOf x'+		]+	where x' = error "Internal error: sizeOf Mtrl: sizeOf accessed its argument!" :: Float++sizeOfMtrlMax :: Mtrl -> Int+sizeOfMtrlMax+	~(Mtrl+		_d _a _s _e _h _angle fl _f alphaFunc _alphaRef+	) = sum $+		[+			sizeOf x' * 4,+			sizeOf x' * 4,+			sizeOf x' * 4,+			sizeOf x' * 4,+			sizeOf x',+			--sizeOf x',+			sizeOf fl,+			solPathMax,+			sizeOf alphaFunc,+			sizeOf x'+		]+	where x' = error "Internal error: sizeOf Mtrl: sizeOf accessed its argument!" :: Float++sizeOfExistingMtrl :: Mtrl -> Int+sizeOfExistingMtrl+	(Mtrl+		_d _a _s _e _h _angle fl _f alphaFunc _alphaRef+	) = sum $+		[+			sizeOf x' * 4,+			sizeOf x' * 4,+			sizeOf x' * 4,+			sizeOf x' * 4,+			sizeOf x',+			--sizeOf x',+			sizeOf fl,+			solPathMax,+			if' ((fl .&. mtrlFlagAlphaTest) /= 0) (sizeOf alphaFunc) 0,+			if' ((fl .&. mtrlFlagAlphaTest) /= 0) (sizeOf x'       ) 0+		]+	where x' = error "Internal error: sizeOf Mtrl: sizeOf accessed its argument!" :: Float++sizeOfPath :: Path -> Int+sizeOfPath = sizeOfPathMax++sizeOfPathMin :: Path -> Int+sizeOfPathMin+	~(Path+		_p _e _t _tm pi_ f s fl _p0 _p1+	) = sum $+		[+			3 * sizeOf x',+			--4 * sizeOf x',+			sizeOf x',+			--sizeOf tm,++			sizeOf pi_,+			sizeOf f,+			sizeOf s,++			sizeOf fl+			--sizeOf p0,+			--sizeOf p1+		]+	where x' = error "Internal error: sizeOf Path: sizeOf accessed its argument!" :: Float++sizeOfPathMax :: Path -> Int+sizeOfPathMax+	~(Path+		_p _e _t _tm pi_ f s fl p0 p1+	) = sum $+		[+			3 * sizeOf x',+			4 * sizeOf x',+			sizeOf x',+			--sizeOf tm,++			sizeOf pi_,+			sizeOf f,+			sizeOf s,++			sizeOf fl,+			sizeOf p0,+			sizeOf p1+		]+	where x' = error "Internal error: sizeOf Path: sizeOf accessed its argument!" :: Float++sizeOfExistingPath :: Path -> Int+sizeOfExistingPath+	(Path+		_p _e _t _tm pi_ f s fl p0 p1+	) = sum $+		[+			3 * sizeOf x',+			if' ((fl .&. pathFlagOriented) /= 0) (4 * sizeOf x') 0,+			sizeOf x',+			--sizeOf tm,++			sizeOf pi_,+			sizeOf f,+			sizeOf s,++			sizeOf fl,+			if' ((fl .&. pathFlagParented) /= 0) (sizeOf p0) 0,+			if' ((fl .&. pathFlagParented) /= 0) (sizeOf p1) 0+		]+	where x' = error "Internal error: sizeOf Path: sizeOf accessed its argument!" :: Float++sizeOfEmptySol :: Sol -> Int+sizeOfEmptySol+	~(Sol+		magic version+		ac dc mc vc ec sc tc oc gc lc nc pc bc hc zc jc xc rc uc wc ic+		--av dv mv vv ev sv tv ov gv lv nv pv bv hv zv jv xv rv uv wv iv+		_  _  _  _  _  _  _  _  _  _  _  _  _  _  _  _  _  _  _  _  _+	) = sum $+		[+			sizeOf magic,+			sizeOf version,++			sizeOf ac,+			sizeOf dc,+			sizeOf mc,+			sizeOf vc,+			sizeOf ec,+			sizeOf sc,+			sizeOf tc,+			sizeOf oc,+			sizeOf gc,+			sizeOf lc,+			sizeOf nc,+			sizeOf pc,+			sizeOf bc,+			sizeOf hc,+			sizeOf zc,+			sizeOf jc,+			sizeOf xc,+			sizeOf rc,+			sizeOf uc,+			sizeOf wc,+			sizeOf ic,++			0 * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: CChar),+			0 * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Dict ),+			0 * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Mtrl ),+			0 * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Vert ),+			0 * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Edge ),+			0 * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Side ),+			0 * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Texc ),+			0 * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Offs ),+			0 * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Geom ),+			0 * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Lump ),+			0 * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Node ),+			0 * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Path ),+			0 * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Body ),+			0 * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Item ),+			0 * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Goal ),+			0 * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Jump ),+			0 * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Swch ),+			0 * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Bill ),+			0 * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Ball ),+			0 * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: View ),+			0 * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Int32)+		]++-- | Accesses its argument!+--+-- Disregards the actual array elements, making this suitable to parse lengths+-- and then judge needed total storage size.+--+-- Get a lower bound by the minimum size of variant width elements, but don't+-- precisely calculate the exact size.+sizeOfExistingSolMin :: Sol -> Int+sizeOfExistingSolMin+	(Sol+		magic version+		ac dc mc vc ec sc tc oc gc lc nc pc bc hc zc jc xc rc uc wc ic+		--av dv mv vv ev sv tv ov gv lv nv pv bv hv zv jv xv rv uv wv iv+		_  _  _  _  _  _  _  _  _  _  _  _  _  _  _  _  _  _  _  _  _+	) = sum $+		[+			sizeOf magic,+			sizeOf version,++			sizeOf ac,+			sizeOf dc,+			sizeOf mc,+			sizeOf vc,+			sizeOf ec,+			sizeOf sc,+			sizeOf tc,+			sizeOf oc,+			sizeOf gc,+			sizeOf lc,+			sizeOf nc,+			sizeOf pc,+			sizeOf bc,+			sizeOf hc,+			sizeOf zc,+			sizeOf jc,+			sizeOf xc,+			sizeOf rc,+			sizeOf uc,+			sizeOf wc,+			sizeOf ic,++			fromIntegral ac * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: CChar),+			fromIntegral dc * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Dict ),+			fromIntegral mc * sizeOfMtrlMin (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Mtrl ),+			fromIntegral vc * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Vert ),+			fromIntegral ec * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Edge ),+			fromIntegral sc * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Side ),+			fromIntegral tc * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Texc ),+			fromIntegral oc * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Offs ),+			fromIntegral gc * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Geom ),+			fromIntegral lc * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Lump ),+			fromIntegral nc * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Node ),+			fromIntegral pc * sizeOfPathMin (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Path ),+			fromIntegral bc * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Body ),+			fromIntegral hc * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Item ),+			fromIntegral zc * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Goal ),+			fromIntegral jc * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Jump ),+			fromIntegral xc * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Swch ),+			fromIntegral rc * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Bill ),+			fromIntegral uc * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Ball ),+			fromIntegral wc * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: View ),+			fromIntegral ic * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Int32)+		]++-- | Accesses its argument!+--+-- Disregards the actual array elements, making this suitable to parse lengths+-- and then judge needed total storage size.+--+-- Get a lower bound by the maximum size of variant width elements, but don't+-- precisely calculate the exact size.+sizeOfExistingSolMax :: Sol -> Int+sizeOfExistingSolMax+	(Sol+		magic version+		ac dc mc vc ec sc tc oc gc lc nc pc bc hc zc jc xc rc uc wc ic+		--av dv mv vv ev sv tv ov gv lv nv pv bv hv zv jv xv rv uv wv iv+		_  _  _  _  _  _  _  _  _  _  _  _  _  _  _  _  _  _  _  _  _+	) = sum $+		[+			sizeOf magic,+			sizeOf version,++			sizeOf ac,+			sizeOf dc,+			sizeOf mc,+			sizeOf vc,+			sizeOf ec,+			sizeOf sc,+			sizeOf tc,+			sizeOf oc,+			sizeOf gc,+			sizeOf lc,+			sizeOf nc,+			sizeOf pc,+			sizeOf bc,+			sizeOf hc,+			sizeOf zc,+			sizeOf jc,+			sizeOf xc,+			sizeOf rc,+			sizeOf uc,+			sizeOf wc,+			sizeOf ic,++			fromIntegral ac * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: CChar),+			fromIntegral dc * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Dict ),+			fromIntegral mc * sizeOfMtrlMax (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Mtrl ),+			fromIntegral vc * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Vert ),+			fromIntegral ec * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Edge ),+			fromIntegral sc * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Side ),+			fromIntegral tc * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Texc ),+			fromIntegral oc * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Offs ),+			fromIntegral gc * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Geom ),+			fromIntegral lc * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Lump ),+			fromIntegral nc * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Node ),+			fromIntegral pc * sizeOfPathMax (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Path ),+			fromIntegral bc * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Body ),+			fromIntegral hc * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Item ),+			fromIntegral zc * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Goal ),+			fromIntegral jc * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Jump ),+			fromIntegral xc * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Swch ),+			fromIntegral rc * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Bill ),+			fromIntegral uc * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Ball ),+			fromIntegral wc * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: View ),+			fromIntegral ic * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Int32)+		]++-- | Accesses its argument!+--+-- Disregards the actual array elements, making this suitable to parse lengths+-- and then judge needed total storage size.+sizeOfExistingSol :: Sol -> Int+sizeOfExistingSol+	(Sol+		magic version+		ac dc mc vc ec sc tc oc gc lc nc pc bc hc zc jc xc rc uc wc ic+		--av dv mv vv ev sv tv ov gv lv nv pv bv hv zv jv xv rv uv wv iv+		_  _  mv _  _  _  _  _  _  _  _  pv _  _  _  _  _  _  _  _  _+	) = sum $+		[+			sizeOf magic,+			sizeOf version,++			sizeOf ac,+			sizeOf dc,+			sizeOf mc,+			sizeOf vc,+			sizeOf ec,+			sizeOf sc,+			sizeOf tc,+			sizeOf oc,+			sizeOf gc,+			sizeOf lc,+			sizeOf nc,+			sizeOf pc,+			sizeOf bc,+			sizeOf hc,+			sizeOf zc,+			sizeOf jc,+			sizeOf xc,+			sizeOf rc,+			sizeOf uc,+			sizeOf wc,+			sizeOf ic,++			fromIntegral ac * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: CChar),+			fromIntegral dc * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Dict ),+			sum . flip map (IA.elems mv) $ \mtrl -> sizeOfExistingMtrl mtrl,+			fromIntegral vc * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Vert ),+			fromIntegral ec * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Edge ),+			fromIntegral sc * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Side ),+			fromIntegral tc * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Texc ),+			fromIntegral oc * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Offs ),+			fromIntegral gc * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Geom ),+			fromIntegral lc * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Lump ),+			fromIntegral nc * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Node ),+			sum . flip map (IA.elems pv) $ \path -> sizeOfExistingPath path,+			fromIntegral bc * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Body ),+			fromIntegral hc * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Item ),+			fromIntegral zc * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Goal ),+			fromIntegral jc * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Jump ),+			fromIntegral xc * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Swch ),+			fromIntegral rc * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Bill ),+			fromIntegral uc * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Ball ),+			fromIntegral wc * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: View ),+			fromIntegral ic * sizeOf (error "Internal error: sizeOf Sol: sizeOf accessed its argument!"  :: Int32)+		]++peeki32Native :: Ptr () -> StateT Int IO Int32+peeki32Native ptr = do+	offset <- get+	val    <- lift $ peek (castPtr ptr `plusPtr` offset)+	put $ offset + sizeOf val+	return val++-- | Read a big-endian encoded int.+peeki32BE :: Ptr () -> StateT Int IO Int32+peeki32BE ptr = do+	offset <- get+	(byte0 :: Word8) <- lift $ peek (castPtr ptr `plusPtr` (offset + 0))+	(byte1 :: Word8) <- lift $ peek (castPtr ptr `plusPtr` (offset + 1))+	(byte2 :: Word8) <- lift $ peek (castPtr ptr `plusPtr` (offset + 2))+	(byte3 :: Word8) <- lift $ peek (castPtr ptr `plusPtr` (offset + 3))+	let (w32 :: Word32) = ((fromIntegral byte0 `shiftL` 24) .|. (fromIntegral byte1 `shiftL` 16) .|. (fromIntegral byte2 `shiftL` 8) .|. (fromIntegral byte3 `shiftL` 0))+	let (i32 :: Int32)  = fromIntegral w32+	let val = i32+	put $ offset + sizeOf w32+	return val++-- | Read a little-endian encoded int, which has backwards byte order (least+-- significant first).+peeki32LE :: Ptr () -> StateT Int IO Int32+peeki32LE ptr = do+	offset <- get+	(byte3 :: Word8) <- lift $ peek (castPtr ptr `plusPtr` (offset + 0))+	(byte2 :: Word8) <- lift $ peek (castPtr ptr `plusPtr` (offset + 1))+	(byte1 :: Word8) <- lift $ peek (castPtr ptr `plusPtr` (offset + 2))+	(byte0 :: Word8) <- lift $ peek (castPtr ptr `plusPtr` (offset + 3))+	let (w32 :: Word32) = ((fromIntegral byte0 `shiftL` 24) .|. (fromIntegral byte1 `shiftL` 16) .|. (fromIntegral byte2 `shiftL` 8) .|. (fromIntegral byte3 `shiftL` 0))+	let (i32 :: Int32)  = fromIntegral w32+	let val = i32+	put $ offset + sizeOf w32+	return val++-- | Read a little-endian encoded float as a double.+peekf32dLE :: Ptr () -> StateT Int IO Double+peekf32dLE ptr = do+	offset <- get+	(byte3 :: Word8) <- lift $ peek (castPtr ptr `plusPtr` (offset + 0))+	(byte2 :: Word8) <- lift $ peek (castPtr ptr `plusPtr` (offset + 1))+	(byte1 :: Word8) <- lift $ peek (castPtr ptr `plusPtr` (offset + 2))+	(byte0 :: Word8) <- lift $ peek (castPtr ptr `plusPtr` (offset + 3))+	let (w32 :: Word32) = ((fromIntegral byte0 `shiftL` 24) .|. (fromIntegral byte1 `shiftL` 16) .|. (fromIntegral byte2 `shiftL` 8) .|. (fromIntegral byte3 `shiftL` 0))++	-- GHC doesn't support coerce between Word32 and Float.+	-- Just malloc a new cfloat.+	{-+	let (f32 :: Float)  = coerce w32+	-}+	(cfloat :: ForeignPtr CFloat) <- lift $ mallocForeignPtr+	(cf32 :: CFloat) <- lift . withForeignPtr cfloat $ \cfloatPtr -> poke (castPtr cfloatPtr) w32 >> peek cfloatPtr+	let (f32 :: Float)  = coerce cf32++	let (d   :: Double) = realToFrac f32+	let val = d+	put $ offset + sizeOf w32+	return val++peekn :: forall a. (Storable a) => Ptr () -> Int32 -> StateT Int IO (Array Int32 a)+peekn ptr n+	| n <= 0    = lift $ newArray_ (0, (-1)) >>= freeze'+	| otherwise = do+		offset <- get+		let elemSizeof = error "Internal error: peekn: sizeOf accessed its element!"  :: a+		let sizeofElem = sizeOf elemSizeof+		array_ <- lift . (>>= freeze') . newGenArray (0, n-1) $ \idx ->+			peek (castPtr ptr `plusPtr` (offset + fromIntegral idx * sizeofElem))+		put $ offset + fromIntegral n * sizeofElem+		let _ = asType elemSizeof (array_ IA.! 0)+		return array_+	where+		freeze' :: IOArray Int32 a -> IO (Array Int32 a)+		freeze' = freeze++peeknWith :: forall a. (Storable a) => (a -> Int) -> Ptr () -> Int32 -> StateT Int IO (Array Int32 a)+peeknWith sizeOf_ ptr n+	| n <= 0    = lift $ newArray_ (0, (-1)) >>= freeze'+	| otherwise = do+		offset <- get+		(elems_, dynSize) <- lift . flip fix (0, 0) $ \me (idx, relOffset) -> do+			if' (idx >= n) (return ([], relOffset)) $ do+			elem_ <- peek (castPtr ptr `plusPtr` (offset + relOffset))+			first (elem_:) <$> me (idx+1, relOffset + sizeOf_ elem_)+		let array_ = IA.listArray (0, n-1) $ elems_+		put $ offset + dynSize+		return array_+	where+		freeze' :: IOArray Int32 a -> IO (Array Int32 a)+		freeze' = freeze++peekCString :: Ptr () -> Int -> StateT Int IO String+peekCString ptr' bufSize = do+	offset <- get+	str <- flip fix 0 $ \withRelOffset relOffset -> do+		if' (relOffset >= bufSize) (return []) $ do+		(c :: Word8) <- lift $ peek (castPtr ptr' `plusPtr` (offset + relOffset))+		if' (c == 0) (return []) $ do+		(asciiChar c:) <$> withRelOffset (relOffset+1)+	put $ offset + bufSize+	return str+	where+		asciiChar :: Word8 -> Char+		asciiChar = toEnum . fromEnum++asType :: a -> a -> ()+asType _ _ = ()++-- mfix doesn't seem quite up to the task; it throws a blocked indefinitely in+-- mvar exception.  Just do it manually.+{-+peekSol :: Ptr Sol -> IO Sol+peekSol ptr = mfix $ \sol -> flip evalStateT 0 $ Sol <$>+	peeki32LE ptr' <*>  -- magic+	peeki32LE ptr' <*>  -- version++	peeki32LE ptr' <*>  -- ac+	peeki32LE ptr' <*>  -- dc+	peeki32LE ptr' <*>  -- mc+	peeki32LE ptr' <*>  -- vc+	peeki32LE ptr' <*>  -- ec+	peeki32LE ptr' <*>  -- sc+	peeki32LE ptr' <*>  -- tc+	peeki32LE ptr' <*>  -- oc+	peeki32LE ptr' <*>  -- gc+	peeki32LE ptr' <*>  -- lc+	peeki32LE ptr' <*>  -- nc+	peeki32LE ptr' <*>  -- pc+	peeki32LE ptr' <*>  -- bc+	peeki32LE ptr' <*>  -- hc+	peeki32LE ptr' <*>  -- zc+	peeki32LE ptr' <*>  -- jc+	peeki32LE ptr' <*>  -- xc+	peeki32LE ptr' <*>  -- rc+	peeki32LE ptr' <*>  -- uc+	peeki32LE ptr' <*>  -- wc+	peeki32LE ptr' <*>  -- ic++	peekn ptr' (sol^.solAc) <*>  -- av+	peekn ptr' (sol^.solDc) <*>  -- dv+	peeknWith sizeOfExistingMtrl ptr' (sol^.solMc) <*>  -- mv+	peekn ptr' (sol^.solVc) <*>  -- vv+	peekn ptr' (sol^.solEc) <*>  -- ev+	peekn ptr' (sol^.solSc) <*>  -- sv+	peekn ptr' (sol^.solTc) <*>  -- tv+	peekn ptr' (sol^.solOc) <*>  -- ov+	peekn ptr' (sol^.solGc) <*>  -- gv+	peekn ptr' (sol^.solLc) <*>  -- lv+	peekn ptr' (sol^.solNc) <*>  -- nv+	peeknWith sizeOfExistingPath ptr' (sol^.solPc) <*>  -- pv+	peekn ptr' (sol^.solBc) <*>  -- bv+	peekn ptr' (sol^.solHc) <*>  -- hv+	peekn ptr' (sol^.solZc) <*>  -- zv+	peekn ptr' (sol^.solJc) <*>  -- jv+	peekn ptr' (sol^.solXc) <*>  -- xv+	peekn ptr' (sol^.solRc) <*>  -- rv+	peekn ptr' (sol^.solUc) <*>  -- uv+	peekn ptr' (sol^.solWc) <*>  -- wv+	peekn ptr' (sol^.solIc)      -- iv++	where ptr' = castPtr ptr+-}+peekSol :: Ptr Sol -> IO Sol+peekSol ptr = flip evalStateT 0 $ do+	magic   <- peeki32LE ptr'+	version <- peeki32LE ptr'++	ac <- peeki32LE ptr'+	dc <- peeki32LE ptr'+	mc <- peeki32LE ptr'+	vc <- peeki32LE ptr'+	ec <- peeki32LE ptr'+	sc <- peeki32LE ptr'+	tc <- peeki32LE ptr'+	oc <- peeki32LE ptr'+	gc <- peeki32LE ptr'+	lc <- peeki32LE ptr'+	nc <- peeki32LE ptr'+	pc <- peeki32LE ptr'+	bc <- peeki32LE ptr'+	hc <- peeki32LE ptr'+	zc <- peeki32LE ptr'+	jc <- peeki32LE ptr'+	xc <- peeki32LE ptr'+	rc <- peeki32LE ptr'+	uc <- peeki32LE ptr'+	wc <- peeki32LE ptr'+	ic <- peeki32LE ptr'++	av <- peekn ptr' ac+	dv <- peekn ptr' dc+	mv <- peeknWith sizeOfExistingMtrl ptr' mc+	vv <- peekn ptr' vc+	ev <- peekn ptr' ec+	sv <- peekn ptr' sc+	tv <- peekn ptr' tc+	ov <- peekn ptr' oc+	gv <- peekn ptr' gc+	lv <- peekn ptr' lc+	nv <- peekn ptr' nc+	pv <- peeknWith sizeOfExistingPath ptr' pc+	bv <- peekn ptr' bc+	hv <- peekn ptr' hc+	zv <- peekn ptr' zc+	jv <- peekn ptr' jc+	xv <- peekn ptr' xc+	rv <- peekn ptr' rc+	uv <- peekn ptr' uc+	wv <- peekn ptr' wc+	iv <- peekn ptr' ic++	return $ Sol {+		_solMagic   = magic,+		_solVersion = version,++		_solAc = ac,+		_solDc = dc,+		_solMc = mc,+		_solVc = vc,+		_solEc = ec,+		_solSc = sc,+		_solTc = tc,+		_solOc = oc,+		_solGc = gc,+		_solLc = lc,+		_solNc = nc,+		_solPc = pc,+		_solBc = bc,+		_solHc = hc,+		_solZc = zc,+		_solJc = jc,+		_solXc = xc,+		_solRc = rc,+		_solUc = uc,+		_solWc = wc,+		_solIc = ic,++		_solAv = av,+		_solDv = dv,+		_solMv = mv,+		_solVv = vv,+		_solEv = ev,+		_solSv = sv,+		_solTv = tv,+		_solOv = ov,+		_solGv = gv,+		_solLv = lv,+		_solNv = nv,+		_solPv = pv,+		_solBv = bv,+		_solHv = hv,+		_solZv = zv,+		_solJv = jv,+		_solXv = xv,+		_solRv = rv,+		_solUv = uv,+		_solWv = wv,+		_solIv = iv+	}++	where ptr' = castPtr ptr++-- | Parse only the lengths, leaving empty arrays.+--+-- This can be used to safely read in a whole SOL file with arbitrary input.+peekSolLengths :: Ptr Sol -> IO Sol+peekSolLengths ptr = flip evalStateT 0 $ Sol <$>+	peeki32LE ptr' <*>  -- magic+	peeki32LE ptr' <*>  -- version++	peeki32LE ptr' <*>  -- ac+	peeki32LE ptr' <*>  -- dc+	peeki32LE ptr' <*>  -- mc+	peeki32LE ptr' <*>  -- vc+	peeki32LE ptr' <*>  -- ec+	peeki32LE ptr' <*>  -- sc+	peeki32LE ptr' <*>  -- tc+	peeki32LE ptr' <*>  -- oc+	peeki32LE ptr' <*>  -- gc+	peeki32LE ptr' <*>  -- lc+	peeki32LE ptr' <*>  -- nc+	peeki32LE ptr' <*>  -- pc+	peeki32LE ptr' <*>  -- bc+	peeki32LE ptr' <*>  -- hc+	peeki32LE ptr' <*>  -- zc+	peeki32LE ptr' <*>  -- jc+	peeki32LE ptr' <*>  -- xc+	peeki32LE ptr' <*>  -- rc+	peeki32LE ptr' <*>  -- uc+	peeki32LE ptr' <*>  -- wc+	peeki32LE ptr' <*>  -- ic++	pure emptyArray <*>  -- av+	pure emptyArray <*>  -- dv+	pure emptyArray <*>  -- mv+	pure emptyArray <*>  -- vv+	pure emptyArray <*>  -- ev+	pure emptyArray <*>  -- sv+	pure emptyArray <*>  -- tv+	pure emptyArray <*>  -- ov+	pure emptyArray <*>  -- gv+	pure emptyArray <*>  -- lv+	pure emptyArray <*>  -- nv+	pure emptyArray <*>  -- pv+	pure emptyArray <*>  -- bv+	pure emptyArray <*>  -- hv+	pure emptyArray <*>  -- zv+	pure emptyArray <*>  -- jv+	pure emptyArray <*>  -- xv+	pure emptyArray <*>  -- rv+	pure emptyArray <*>  -- uv+	pure emptyArray <*>  -- wv+	pure emptyArray      -- iv++	where+		ptr' = castPtr ptr+		a :: (Storable a) => Array Int32 a+		a = IA.listArray (0, -1) []+		emptyArray :: (Storable a) => Array Int32 a+		emptyArray = a++pokeSol :: Ptr Sol -> Sol -> IO ()+pokeSol ptr+	(Sol+		magic version+		ac dc mc vc ec sc tc oc gc lc nc pc bc hc zc jc xc rc uc wc ic+		av dv mv vv ev sv tv ov gv lv nv pv bv hv zv jv xv rv uv wv iv+	) = flip evalStateT 0 $ do+		pokei32LE ptr' magic+		pokei32LE ptr' version++		pokei32LE ptr' ac+		pokei32LE ptr' dc+		pokei32LE ptr' mc+		pokei32LE ptr' vc+		pokei32LE ptr' ec+		pokei32LE ptr' sc+		pokei32LE ptr' tc+		pokei32LE ptr' oc+		pokei32LE ptr' gc+		pokei32LE ptr' lc+		pokei32LE ptr' nc+		pokei32LE ptr' pc+		pokei32LE ptr' bc+		pokei32LE ptr' hc+		pokei32LE ptr' zc+		pokei32LE ptr' jc+		pokei32LE ptr' xc+		pokei32LE ptr' rc+		pokei32LE ptr' uc+		pokei32LE ptr' wc+		pokei32LE ptr' ic++		poken ptr' ac av+		poken ptr' dc dv+		pokenWith sizeOfExistingMtrl ptr' mc mv+		poken ptr' vc vv+		poken ptr' ec ev+		poken ptr' sc sv+		poken ptr' tc tv+		poken ptr' oc ov+		poken ptr' gc gv+		poken ptr' lc lv+		poken ptr' nc nv+		pokenWith sizeOfExistingPath ptr' pc pv+		poken ptr' bc bv+		poken ptr' hc hv+		poken ptr' zc zv+		poken ptr' jc jv+		poken ptr' xc xv+		poken ptr' rc rv+		poken ptr' uc uv+		poken ptr' wc wv+		poken ptr' ic iv++	where ptr' = castPtr ptr++pokei32Native :: Ptr () -> Int32 -> StateT Int IO ()+pokei32Native ptr val = do+	offset <- get+	lift $ poke (castPtr ptr `plusPtr` offset) val+	put $ offset + sizeOf val++pokei32BE :: Ptr () -> Int32 -> StateT Int IO ()+pokei32BE ptr val = do+	offset <- get+	let (w32 :: Word32) = fromIntegral val+	let (byte0 :: Word8) = fromIntegral $ (w32 .&. 0xFF000000) `shiftR` 24+	let (byte1 :: Word8) = fromIntegral $ (w32 .&. 0x00FF0000) `shiftR` 16+	let (byte2 :: Word8) = fromIntegral $ (w32 .&. 0x0000FF00) `shiftR`  8+	let (byte3 :: Word8) = fromIntegral $ (w32 .&. 0x000000FF) `shiftR`  0+	lift $ poke (castPtr ptr `plusPtr` (offset + 0)) byte0+	lift $ poke (castPtr ptr `plusPtr` (offset + 1)) byte1+	lift $ poke (castPtr ptr `plusPtr` (offset + 2)) byte2+	lift $ poke (castPtr ptr `plusPtr` (offset + 3)) byte3+	put $ offset + sizeOf w32++pokei32LE :: Ptr () -> Int32 -> StateT Int IO ()+pokei32LE ptr val = do+	offset <- get+	let (w32 :: Word32) = fromIntegral val+	let (byte3 :: Word8) = fromIntegral $ (w32 .&. 0xFF000000) `shiftR` 24+	let (byte2 :: Word8) = fromIntegral $ (w32 .&. 0x00FF0000) `shiftR` 16+	let (byte1 :: Word8) = fromIntegral $ (w32 .&. 0x0000FF00) `shiftR`  8+	let (byte0 :: Word8) = fromIntegral $ (w32 .&. 0x000000FF) `shiftR`  0+	lift $ poke (castPtr ptr `plusPtr` (offset + 0)) byte0+	lift $ poke (castPtr ptr `plusPtr` (offset + 1)) byte1+	lift $ poke (castPtr ptr `plusPtr` (offset + 2)) byte2+	lift $ poke (castPtr ptr `plusPtr` (offset + 3)) byte3+	put $ offset + sizeOf w32++pokef32dLE :: Ptr () -> Double -> StateT Int IO ()+pokef32dLE ptr val = do+	offset <- get+	let (fl :: Float) = realToFrac val++	-- GHC doesn't support coerce between Float and Word32.+	-- Just malloc a new word32.+	{-+	let (w32 :: Word32) = coerce f+	-}+	(w32Ptr :: ForeignPtr Word32) <- lift $ mallocForeignPtr+	(cw32 :: Word32) <- lift . withForeignPtr w32Ptr $ \ptr_ -> poke (castPtr ptr_) fl >> peek ptr_+	let (w32 :: Word32) = coerce cw32++	let (byte3 :: Word8) = fromIntegral $ (w32 .&. 0xFF000000) `shiftR` 24+	let (byte2 :: Word8) = fromIntegral $ (w32 .&. 0x00FF0000) `shiftR` 16+	let (byte1 :: Word8) = fromIntegral $ (w32 .&. 0x0000FF00) `shiftR`  8+	let (byte0 :: Word8) = fromIntegral $ (w32 .&. 0x000000FF) `shiftR`  0+	lift $ poke (castPtr ptr `plusPtr` (offset + 0)) byte0+	lift $ poke (castPtr ptr `plusPtr` (offset + 1)) byte1+	lift $ poke (castPtr ptr `plusPtr` (offset + 2)) byte2+	lift $ poke (castPtr ptr `plusPtr` (offset + 3)) byte3+	put $ offset + sizeOf w32++poken :: forall a. (Storable a) => Ptr () -> Int32 -> Array Int32 a -> StateT Int IO ()+poken ptr n array_+	| n <= 0    = return ()+	| otherwise = do+		let elemSizeof = error "Internal error: poken: sizeOf accessed its element!"  :: a+		let sizeofElem = sizeOf elemSizeof+		forM_ array_ $ \elem_ -> do+			offset <- get+			lift $ poke (castPtr ptr `plusPtr` offset) elem_+			put $ offset + sizeofElem++pokenWith :: forall a. (Storable a) => (a -> Int) -> Ptr () -> Int32 -> Array Int32 a -> StateT Int IO ()+pokenWith sizeOf_ ptr n array_+	| n <= 0    = return ()+	| otherwise = do+		forM_ array_ $ \elem_ -> do+			offset <- get+			lift $ poke (castPtr ptr `plusPtr` offset) elem_+			put $ offset + sizeOf_ elem_++pokeCString :: Ptr () -> Int -> String -> StateT Int IO ()+pokeCString ptr bufSize str+	| bufSize <= 0 = return ()+	| otherwise = do+		offset <- get+		let strLen = max (bufSize - 1) $ length str+		forM_ (zip [0..] (take strLen $ str)) $ \(idx, c) -> do+			lift $ poke (castPtr ptr `plusPtr` (offset + idx)) $ truncateChar c+		lift $ poke (castPtr ptr `plusPtr` (offset + (strLen - 1))) (0x00 :: Word8)+		put $ offset + bufSize+	where+		truncateChar :: Char -> Word8+		truncateChar = toEnum . fromEnum++instance Storable Mtrl where+	sizeOf = sizeOfMtrlMax+	alignment+		~(Mtrl+			_d _a _s _e h _angle fl _f alphaFunc _alphaRef+		) = max 1 . maximum $+			[+				alignment x',+				alignment x',+				alignment x',+				alignment x',+				alignment h,+				--alignment angle,+				alignment fl,+				1,+				alignment alphaFunc,+				alignment x'+			]+		where x' = error "Internal error: alignment Mtrl: alignment accessed its argument!" :: Float++	-- Irregular encoding; replace straightforward.+	{-+	peek ptr = flip evalStateT 0 $ Mtrl <$>+		(Vec4 <$> peekf32dLE ptr' <*> peekf32dLE ptr' <*> peekf32dLE ptr' <*> peekf32dLE ptr') <*>  -- mtrlD+		(Vec4 <$> peekf32dLE ptr' <*> peekf32dLE ptr' <*> peekf32dLE ptr' <*> peekf32dLE ptr') <*>  -- mtrlA+		(Vec4 <$> peekf32dLE ptr' <*> peekf32dLE ptr' <*> peekf32dLE ptr' <*> peekf32dLE ptr') <*>  -- mtrlS+		(Vec4 <$> peekf32dLE ptr' <*> peekf32dLE ptr' <*> peekf32dLE ptr' <*> peekf32dLE ptr') <*>  -- mtrlE+		peekf32dLE ptr' <*>  -- mtrlH++		peekf32dLE ptr' <*>  -- mtrlAngle++		peeki32LE ptr' <*>  -- mtrlFl++		peekCString ptr' solPathMax <*>  -- mtrlF++		peeki32LE ptr' <*>  -- mtrlAlphaFunc+		peekf32dLE ptr'  -- mtrlAlphaRef++		where ptr' = castPtr ptr++	poke ptr+		(Mtrl+			d a s e h angle fl f alphaFunc alphaRef+		) = flip evalStateT 0 $ do+			pokef32dLE ptr' (d^.x4) >> pokef32dLE ptr' (d^.y4) >> pokef32dLE ptr' (d^.z4) >> pokef32dLE ptr' (d^.w4)+			pokef32dLE ptr' (a^.x4) >> pokef32dLE ptr' (a^.y4) >> pokef32dLE ptr' (a^.z4) >> pokef32dLE ptr' (a^.w4)+			pokef32dLE ptr' (s^.x4) >> pokef32dLE ptr' (s^.y4) >> pokef32dLE ptr' (s^.z4) >> pokef32dLE ptr' (s^.w4)+			pokef32dLE ptr' (e^.x4) >> pokef32dLE ptr' (e^.y4) >> pokef32dLE ptr' (e^.z4) >> pokef32dLE ptr' (e^.w4)+			pokef32dLE ptr' h++			pokef32dLE ptr' angle++			pokei32LE ptr' fl++			pokeCString ptr' solPathMax f++			pokei32LE ptr' alphaFunc+			pokef32dLE ptr' alphaRef++		where ptr' = castPtr ptr+	-}++	peek ptr = flip evalStateT 0 $ do+		d <- Vec4 <$> peekf32dLE ptr' <*> peekf32dLE ptr' <*> peekf32dLE ptr' <*> peekf32dLE ptr'+		a <- Vec4 <$> peekf32dLE ptr' <*> peekf32dLE ptr' <*> peekf32dLE ptr' <*> peekf32dLE ptr'+		s <- Vec4 <$> peekf32dLE ptr' <*> peekf32dLE ptr' <*> peekf32dLE ptr' <*> peekf32dLE ptr'+		e <- Vec4 <$> peekf32dLE ptr' <*> peekf32dLE ptr' <*> peekf32dLE ptr' <*> peekf32dLE ptr'+		h <- peekf32dLE ptr'++		let angle = 0.0++		fl <- peeki32LE ptr'++		f <- peekCString ptr' solPathMax++		alphaFunc <- if' ((fl .&. mtrlFlagAlphaTest) /= 0) (peeki32LE  ptr') (pure 0  )+		alphaRef  <- if' ((fl .&. mtrlFlagAlphaTest) /= 0) (peekf32dLE ptr') (pure 0.0)++		return $ Mtrl {+			_mtrlD = d,+			_mtrlA = a,+			_mtrlS = s,+			_mtrlE = e,+			_mtrlH = h,++			_mtrlAngle = angle,++			_mtrlFl = fl,+			_mtrlF  = f,++			_mtrlAlphaFunc = alphaFunc,+			_mtrlAlphaRef  = alphaRef+		}++		where ptr' = castPtr ptr++	poke ptr+		(Mtrl+			d a s e h _angle fl f alphaFunc alphaRef+		) = flip evalStateT 0 $ do+			pokef32dLE ptr' (d^.x4) >> pokef32dLE ptr' (d^.y4) >> pokef32dLE ptr' (d^.z4) >> pokef32dLE ptr' (d^.w4)+			pokef32dLE ptr' (a^.x4) >> pokef32dLE ptr' (a^.y4) >> pokef32dLE ptr' (a^.z4) >> pokef32dLE ptr' (a^.w4)+			pokef32dLE ptr' (s^.x4) >> pokef32dLE ptr' (s^.y4) >> pokef32dLE ptr' (s^.z4) >> pokef32dLE ptr' (s^.w4)+			pokef32dLE ptr' (e^.x4) >> pokef32dLE ptr' (e^.y4) >> pokef32dLE ptr' (e^.z4) >> pokef32dLE ptr' (e^.w4)+			pokef32dLE ptr' h++			--pokef32dLE ptr' angle++			pokei32LE ptr' fl++			pokeCString ptr' solPathMax f++			when ((fl .&. mtrlFlagAlphaTest) /= 0) $ pokei32LE  ptr' alphaFunc+			when ((fl .&. mtrlFlagAlphaTest) /= 0) $ pokef32dLE ptr' alphaRef++		where ptr' = castPtr ptr++instance Storable Vert where+	sizeOf    ~(Vert (Vec3 _ _ _)) = sum [3 * sizeOf x']+		where x' = error "Internal error: sizeOf Vert: sizeOf accessed its argument!" :: Float+	alignment ~(Vert (Vec3 _ _ _)) = max 1 $ maximum [alignment x']+		where x' = error "Internal error: alignment Vert: alignment accessed its argument!" :: Float+	peek ptr = flip evalStateT 0 $ Vert <$> (Vec3 <$> peekf32dLE ptr' <*> peekf32dLE ptr' <*> peekf32dLE ptr')+		where ptr' = castPtr ptr+	poke ptr (Vert (Vec3 x y z)) = flip evalStateT 0 $ pokef32dLE ptr' x >> pokef32dLE ptr' y >> pokef32dLE ptr' z+		where ptr' = castPtr ptr++instance Storable Edge where+	sizeOf    ~(Edge vi vj) = sum [sizeOf vi, sizeOf vj]+	alignment ~(Edge vi vj) = max 1 $ maximum [alignment vi, alignment vj]+	peek ptr = flip evalStateT 0 $ Edge <$> peeki32LE ptr' <*> peeki32LE ptr'+		where ptr' = castPtr ptr+	poke ptr (Edge vi vj) = flip evalStateT 0 $ pokei32LE ptr' vi >> pokei32LE ptr' vj+		where ptr' = castPtr ptr++instance Storable Side where+	sizeOf    ~(Side (Vec3 _nx _ny _nz) _d) = sum [3 * sizeOf x', sizeOf x']+		where x' = error "Internal error: sizeOf Side: sizeOf accessed its argument!" :: Float+	alignment ~(Side (Vec3 _nx _ny _nz) _d) = max 1 $ maximum [alignment x', alignment x']+		where x' = error "Internal error: alignment Side: alignment accessed its argument!" :: Float+	peek ptr = flip evalStateT 0 $ Side <$> (Vec3 <$> peekf32dLE ptr' <*> peekf32dLE ptr' <*> peekf32dLE ptr') <*> peekf32dLE ptr'+		where ptr' = castPtr ptr+	poke ptr (Side (Vec3 nx ny nz) d) = flip evalStateT 0 $ pokef32dLE ptr' nx >> pokef32dLE ptr' ny >> pokef32dLE ptr' nz >> pokef32dLE ptr' d+		where ptr' = castPtr ptr++instance Storable Texc where+	sizeOf    ~(Texc (Vec2 _tx _ty)) = sum [2 * sizeOf x']+		where x' = error "Internal error: sizeOf Texc: sizeOf accessed its argument!" :: Float+	alignment ~(Texc (Vec2 _tx _ty)) = max 1 $ maximum [alignment x', alignment x']+		where x' = error "Internal error: alignment Texc: alignment accessed its argument!" :: Float+	peek ptr = flip evalStateT 0 $ Texc <$> (Vec2 <$> peekf32dLE ptr' <*> peekf32dLE ptr')+		where ptr' = castPtr ptr+	poke ptr (Texc (Vec2 tx ty)) = flip evalStateT 0 $ pokef32dLE ptr' tx >> pokef32dLE ptr' ty+		where ptr' = castPtr ptr++instance Storable Offs where+	sizeOf    ~(Offs ti si vi) = sum [sizeOf ti, sizeOf si, sizeOf vi]+	alignment ~(Offs ti si vi) = max 1 $ maximum [alignment ti, alignment si, alignment vi]+	peek ptr = flip evalStateT 0 $ Offs <$> peeki32LE ptr' <*> peeki32LE ptr' <*> peeki32LE ptr'+		where ptr' = castPtr ptr+	poke ptr (Offs ti si vi) = flip evalStateT 0 $ pokei32LE ptr' ti >> pokei32LE ptr' si >> pokei32Native ptr' vi+		where ptr' = castPtr ptr++instance Storable Geom where+	sizeOf    ~(Geom mi oi oj ok) = sum [sizeOf mi, sizeOf oi, sizeOf oj, sizeOf ok]+	alignment ~(Geom mi oi oj ok) = max 1 $ maximum [alignment mi, alignment oi, alignment oj, alignment ok]+	peek ptr = flip evalStateT 0 $ Geom <$> peeki32LE ptr' <*> peeki32LE ptr' <*> peeki32LE ptr' <*> peeki32LE ptr'+		where ptr' = castPtr ptr+	poke ptr (Geom mi oi oj ok) = flip evalStateT 0 $ pokei32LE ptr' mi >> pokei32LE ptr' oi >> pokei32Native ptr' oj >> pokei32LE ptr' ok+		where ptr' = castPtr ptr++instance Storable Lump where+	sizeOf    ~(Lump fl v0 vc e0 ec g0 gc s0 sc) = sum [sizeOf fl, sizeOf v0, sizeOf vc, sizeOf e0, sizeOf ec, sizeOf g0, sizeOf gc, sizeOf s0, sizeOf sc]+	alignment ~(Lump fl v0 vc e0 ec g0 gc s0 sc) = max 1 $ maximum [alignment fl, alignment v0, alignment vc, alignment e0, alignment ec, alignment g0, alignment gc, alignment s0, alignment sc]+	peek ptr = flip evalStateT 0 $ Lump <$> peeki32LE ptr' <*> peeki32LE ptr' <*> peeki32LE ptr' <*> peeki32LE ptr' <*> peeki32LE ptr' <*> peeki32LE ptr' <*> peeki32LE ptr' <*> peeki32LE ptr' <*> peeki32LE ptr'+		where ptr' = castPtr ptr+	poke ptr (Lump fl v0 vc e0 ec g0 gc s0 sc) = flip evalStateT 0 $ pokei32LE ptr' fl >> pokei32LE ptr' v0 >> pokei32LE ptr' vc >> pokei32LE ptr' e0 >> pokei32LE ptr' ec >> pokei32LE ptr' g0 >> pokei32LE ptr' gc >> pokei32LE ptr' s0 >> pokei32LE ptr' sc+		where ptr' = castPtr ptr++instance Storable Node where+	sizeOf    ~(Node si ni nj l0 lc) = sum [sizeOf si, sizeOf ni, sizeOf nj, sizeOf l0, sizeOf lc]+	alignment ~(Node si ni nj l0 lc) = max 1 $ maximum [alignment si, alignment ni, alignment nj, alignment l0, alignment lc]+	peek ptr = flip evalStateT 0 $ Node <$> peeki32LE ptr' <*> peeki32LE ptr' <*> peeki32LE ptr' <*> peeki32LE ptr' <*> peeki32LE ptr'+		where ptr' = castPtr ptr+	poke ptr (Node si ni nj l0 lc) = flip evalStateT 0 $ pokei32LE ptr' si >> pokei32LE ptr' ni >> pokei32LE ptr' nj >> pokei32LE ptr' l0 >> pokei32LE ptr' lc+		where ptr' = castPtr ptr++instance Storable Path where+	sizeOf = sizeOfPathMax+	alignment+		~(Path+			_p _e _t _tm pi_ f s fl p0 p1+		) = max 1 . maximum $+			[+				alignment x',+				alignment x',+				alignment x',+				--alignment tm,++				alignment pi_,+				alignment f,+				alignment s,++				alignment fl,+				alignment p0,+				alignment p1+			]+		where x' = error "Internal error: alignment Path: alignment accessed its argument!" :: Float++	{-+	peek ptr = flip evalStateT 0 $ Path <$>+		(Vec3 <$> peekf32dLE ptr' <*> peekf32dLE ptr' <*> peekf32dLE ptr') <*>  -- p+		(Vec4 <$> peekf32dLE ptr' <*> peekf32dLE ptr' <*> peekf32dLE ptr' <*> peekf32dLE ptr') <*>  -- e+		peekf32dLE ptr' <*>  -- t+		peeki32LE ptr' <*>  -- tm++		peeki32LE ptr' <*>  -- pi+		peeki32LE ptr' <*>  -- f+		peeki32LE ptr' <*>  -- s++		peeki32LE ptr' <*>  -- fl++		peeki32LE ptr' <*>  -- p0+		peeki32LE ptr'  -- p1++		where ptr' = castPtr ptr++	poke ptr+		(Path+			(Vec3 px py pz) (Vec4 ex ey ez ew) t tm pi_ f s fl p0 p1+		) = flip evalStateT 0 $ do+			pokef32dLE ptr' px >> pokef32dLE ptr' py >> pokef32dLE ptr' pz+			pokef32dLE ptr' ex >> pokef32dLE ptr' ey >> pokef32dLE ptr' ez >> pokef32dLE ptr' ew+			pokef32dLE ptr' t+			pokei32LE ptr' tm++			pokei32LE ptr' pi_+			pokei32LE ptr' f+			pokei32LE ptr' s++			pokei32LE ptr' fl++			pokei32LE ptr' p0+			pokei32LE ptr' p1++		where ptr' = castPtr ptr+	-}+	-- Actually, Paths are serialized in a different order, and are also+	-- variable width.  So we'll need to provide special implementations+	-- carefully.+	peek ptr = flip evalStateT 0 $ do+		p   <- Vec3 <$> peekf32dLE ptr' <*> peekf32dLE ptr' <*> peekf32dLE ptr'+		t   <- peekf32dLE ptr'+		pi_ <- peeki32LE ptr'+		f   <- peeki32LE ptr'+		s   <- peeki32LE ptr'+		fl  <- peeki32LE ptr'++		e        <- if' ((fl .&. pathFlagOriented) /= 0) (Vec4 <$> peekf32dLE ptr' <*> peekf32dLE ptr' <*> peekf32dLE ptr' <*> peekf32dLE ptr') (return $ Vec4 0.0 0.0 0.0 0.0)+		(p0, p1) <- if' ((fl .&. pathFlagParented) /= 0) ((,)  <$> peeki32LE  ptr' <*> peeki32LE  ptr'                                        ) (return $ (0, 0))++		let tm = round $ (1000.0*t)++		let p1' = if' (p1 < 0) p0 p1++		return $ Path {+			_pathP  = p,+			_pathE  = e,+			_pathT  = t,+			_pathTm = tm,++			_pathPi = pi_,+			_pathF  = f,+			_pathS  = s,++			_pathFl = fl,++			_pathP0 = p0,+			_pathP1 = p1'+		}++		where ptr' = castPtr ptr+	poke ptr+		(Path+			(Vec3 px py pz) (Vec4 ex ey ez ew) t _tm pi_ f s fl p0 p1+		) = flip evalStateT 0 $ do+			pokef32dLE ptr' px >> pokef32dLE ptr' py >> pokef32dLE ptr' pz+			pokef32dLE ptr' t+			pokei32LE  ptr' pi_+			pokei32LE  ptr' f+			pokei32LE  ptr' s+			pokei32LE  ptr' fl++			when ((fl .&. pathFlagOriented) /= 0) (pokef32dLE ptr' ex >> pokef32dLE ptr' ey >> pokef32dLE ptr' ez >> pokef32dLE ptr' ew)+			when ((fl .&. pathFlagParented) /= 0) (pokei32LE ptr' p0 >> pokei32LE ptr' p1)++		where ptr' = castPtr ptr++instance Storable Body where+	sizeOf    ~(Body p0 p1 ni l0 lc g0 gc) = sum [sizeOf p0, sizeOf p1, sizeOf ni, sizeOf l0, sizeOf lc, sizeOf g0, sizeOf gc]+	alignment ~(Body p0 p1 ni l0 lc g0 gc) = max 1 $ maximum [alignment p0, alignment p1, alignment ni, alignment l0, alignment lc, alignment g0, alignment gc]+	peek ptr = flip evalStateT 0 $ Body <$> peeki32LE ptr' <*> peeki32LE ptr' <*> peeki32LE ptr' <*> peeki32LE ptr' <*> peeki32LE ptr' <*> peeki32LE ptr' <*> peeki32LE ptr'+		where ptr' = castPtr ptr+	poke ptr (Body p0 p1 ni l0 lc g0 gc) = flip evalStateT 0 $ pokei32LE ptr' p0 >> pokei32LE ptr' p1 >> pokei32Native ptr' ni >> pokei32LE ptr' l0 >> pokei32LE ptr' lc >> pokei32Native ptr' g0 >> pokei32LE ptr' gc+		where ptr' = castPtr ptr++instance Storable Item where+	sizeOf+		~(Item+			_p t n p0 p1+		) = sum $+			[+				3 * sizeOf x',+				sizeOf t,+				sizeOf n,++				sizeOf p0,+				sizeOf p1+			]+		where x' = error "Internal error: sizeOf Item: sizeOf accessed its argument!" :: Float+	alignment+		~(Item+			_p t n p0 p1+		) = max 1 . maximum $+			[+				alignment x',+				alignment t,+				alignment n,++				alignment p0,+				alignment p1+			]+		where x' = error "Internal error: alignment Item: alignment accessed its argument!" :: Float++	peek ptr = ((\item -> item & (itemP1 .~ (if' (item^.itemP1 < 0) (item^.itemP0) (item^.itemP1)))) <$>) . flip evalStateT 0 $ Item <$>+		(Vec3 <$> peekf32dLE ptr' <*> peekf32dLE ptr' <*> peekf32dLE ptr') <*>  -- p+		peeki32LE ptr' <*>  -- t+		peeki32LE ptr' <*>  -- n++		peeki32LE ptr' <*>  -- p0+		peeki32LE ptr'      -- p1++		where ptr' = castPtr ptr++	poke ptr+		(Item+			(Vec3 px py pz) t n p0 p1+		) = flip evalStateT 0 $ do+			pokef32dLE ptr' px >> pokef32dLE ptr' py >> pokef32dLE ptr' pz+			pokei32LE ptr' t+			pokei32LE ptr' n++			pokei32LE ptr' p0+			pokei32LE ptr' p1++		where ptr' = castPtr ptr++instance Storable Goal where+	sizeOf+		~(Goal+			_p _r p0 p1+		) = sum $+			[+				3 * sizeOf x',+				sizeOf x',++				sizeOf p0,+				sizeOf p1+			]+		where x' = error "Internal error: sizeOf Item: sizeOf accessed its argument!" :: Float+	alignment+		~(Goal+			_p _r p0 p1+		) = max 1 . maximum $+			[+				alignment x',+				alignment x',++				alignment p0,+				alignment p1+			]+		where x' = error "Internal error: alignment Item: alignment accessed its argument!" :: Float++	peek ptr = ((\goal -> goal & (goalP1 .~ (if' (goal^.goalP1 < 0) (goal^.goalP0) (goal^.goalP1)))) <$>) . flip evalStateT 0 $ Goal <$>+		(Vec3 <$> peekf32dLE ptr' <*> peekf32dLE ptr' <*> peekf32dLE ptr') <*>  -- p+		peekf32dLE ptr' <*>  -- r++		peeki32LE ptr' <*>  -- p0+		peeki32LE ptr'      -- p1++		where ptr' = castPtr ptr++	poke ptr+		(Goal+			(Vec3 px py pz) r p0 p1+		) = flip evalStateT 0 $ do+			pokef32dLE ptr' px >> pokef32dLE ptr' py >> pokef32dLE ptr' pz+			pokef32dLE ptr' r++			pokei32LE ptr' p0+			pokei32LE ptr' p1++		where ptr' = castPtr ptr++instance Storable Jump where+	sizeOf+		~(Jump+			_p _q _r p0 p1+		) = sum $+			[+				3 * sizeOf x',+				3 * sizeOf x',+				sizeOf x',++				sizeOf p0,+				sizeOf p1+			]+		where x' = error "Internal error: sizeOf Jump: sizeOf accessed its argument!" :: Float+	alignment+		~(Jump+			_p _q _r p0 p1+		) = max 1 . maximum $+			[+				alignment x',+				alignment x',+				alignment x',++				alignment p0,+				alignment p1+			]+		where x' = error "Internal error: alignment Jump: alignment accessed its argument!" :: Float++	peek ptr = ((\jump -> jump & (jumpP1 .~ (if' (jump^.jumpP1 < 0) (jump^.jumpP0) (jump^.jumpP1)))) <$>) . flip evalStateT 0 $ Jump <$>+		(Vec3 <$> peekf32dLE ptr' <*> peekf32dLE ptr' <*> peekf32dLE ptr') <*>  -- p+		(Vec3 <$> peekf32dLE ptr' <*> peekf32dLE ptr' <*> peekf32dLE ptr') <*>  -- q+		peekf32dLE ptr' <*>  -- r++		peeki32LE ptr' <*>  -- p0+		peeki32LE ptr'      -- p1++		where ptr' = castPtr ptr++	poke ptr+		(Jump+			(Vec3 px py pz) (Vec3 qx qy qz) r p0 p1+		) = flip evalStateT 0 $ do+			pokef32dLE ptr' px >> pokef32dLE ptr' py >> pokef32dLE ptr' pz+			pokef32dLE ptr' qx >> pokef32dLE ptr' qy >> pokef32dLE ptr' qz+			pokef32dLE ptr' r++			pokei32LE ptr' p0+			pokei32LE ptr' p1++		where ptr' = castPtr ptr++instance Storable Swch where+	sizeOf+		~(Swch+			_p _r pi_ _t _tm f i p0 p1+		) = sum $+			[+				3 * sizeOf x',+				sizeOf x',+				sizeOf pi_,+				sizeOf x', sizeOf x',+				--sizeOf tm,+				sizeOf f, sizeOf f,+				sizeOf i,++				sizeOf p0,+				sizeOf p1+			]+		where x' = error "Internal error: sizeOf Swch: sizeOf accessed its argument!" :: Float+	alignment+		~(Swch+			_p _r pi_ _t _tm f i p0 p1+		) = max 1 . maximum $+			[+				alignment x',+				alignment x',+				alignment pi_,+				alignment x',+				--alignment tm,+				alignment f,+				alignment i,++				alignment p0,+				alignment p1+			]+		where x' = error "Internal error: alignment Swch: alignment accessed its argument!" :: Float++	peek ptr =+		((\swch -> swch & (swchP1 .~ (if' (swch^.swchP1 < 0) (swch^.swchP0) (swch^.swchP1)))) <$>) .+		((\swch -> swch & (swchTm .~ (round $ 1000.0*(swch^.swchT)))) <$>) . flip evalStateT 0 $ Swch <$>+		(Vec3 <$> peekf32dLE ptr' <*> peekf32dLE ptr' <*> peekf32dLE ptr') <*>  -- p+		peekf32dLE ptr' <*>  -- r+		peeki32LE ptr' <*>  -- pi++		(peekf32dLE ptr' <* peekf32dLE ptr') <*>  -- t (skip f32)+		pure 0 <*>  -- tm+		(peeki32LE ptr' <* peeki32LE ptr') <*>  -- f (skip i32)+		peeki32LE ptr' <*>  -- i++		peeki32LE ptr' <*>  -- p0+		peeki32LE ptr'      -- p1++		where ptr' = castPtr ptr++	poke ptr+		(Swch+			(Vec3 px py pz) r pi_ t _tm f i p0 p1+		) = flip evalStateT 0 $ do+			pokef32dLE ptr' px >> pokef32dLE ptr' py >> pokef32dLE ptr' pz+			pokef32dLE ptr' r+			pokei32LE ptr' pi_++			pokef32dLE ptr' t >> pokef32dLE ptr' t+			--pokei32LE ptr' tm+			pokei32LE ptr' f >> pokei32LE ptr' f+			pokei32LE ptr' i++			pokei32LE ptr' p0+			pokei32LE ptr' p1++		where ptr' = castPtr ptr++instance Storable Bill where+	sizeOf+		~(Bill+			fl mi _t _d _w _h _rx _ry _rz _p p0 p1+		) = sum $+			[+				sizeOf fl,+				sizeOf mi,+				sizeOf x',+				sizeOf x',++				3 * sizeOf x',+				3 * sizeOf x',++				3 * sizeOf x',+				3 * sizeOf x',+				3 * sizeOf x',++				3 * sizeOf x',++				sizeOf p0,+				sizeOf p1+			]+		where x' = error "Internal error: sizeOf Bill: sizeOf accessed its argument!" :: Float+	alignment+		~(Bill+			fl mi _t _d _w _h _rx _ry _rz _p p0 p1+		) = max 1 . maximum $+			[+				alignment fl,+				alignment mi,+				alignment x',+				alignment x',++				alignment x',+				alignment x',++				alignment x',+				alignment x',+				alignment x',++				alignment x',++				alignment p0,+				alignment p1+			]+		where x' = error "Internal error: alignment Bill: alignment accessed its argument!" :: Float++	peek ptr = ((\bill -> bill & (billP1 .~ (if' (bill^.billP1 < 0) (bill^.billP0) (bill^.billP1)))) <$>) . flip evalStateT 0 $ Bill <$>+		peeki32LE ptr' <*>  -- fl+		peeki32LE ptr' <*>  -- mi+		peekf32dLE ptr' <*>  -- t+		peekf32dLE ptr' <*>  -- d++		(Vec3 <$> peekf32dLE ptr' <*> peekf32dLE ptr' <*> peekf32dLE ptr') <*>  -- w+		(Vec3 <$> peekf32dLE ptr' <*> peekf32dLE ptr' <*> peekf32dLE ptr') <*>  -- h++		(Vec3 <$> peekf32dLE ptr' <*> peekf32dLE ptr' <*> peekf32dLE ptr') <*>  -- rx+		(Vec3 <$> peekf32dLE ptr' <*> peekf32dLE ptr' <*> peekf32dLE ptr') <*>  -- ry+		(Vec3 <$> peekf32dLE ptr' <*> peekf32dLE ptr' <*> peekf32dLE ptr') <*>  -- rz++		(Vec3 <$> peekf32dLE ptr' <*> peekf32dLE ptr' <*> peekf32dLE ptr') <*>  -- p++		peeki32LE ptr' <*>  -- p0+		peeki32LE ptr'      -- p1++		where ptr' = castPtr ptr++	poke ptr+		(Bill+			fl mi t d (Vec3 wx wy wz) (Vec3 hx hy hz) (Vec3 rxx rxy rxz) (Vec3 ryx ryy ryz) (Vec3 rzx rzy rzz) (Vec3 px py pz) p0 p1+		) = flip evalStateT 0 $ do+			pokei32LE ptr' fl+			pokei32LE ptr' mi+			pokef32dLE ptr' t+			pokef32dLE ptr' d++			pokef32dLE ptr' wx >> pokef32dLE ptr' wy >> pokef32dLE ptr' wz+			pokef32dLE ptr' hx >> pokef32dLE ptr' hy >> pokef32dLE ptr' hz++			pokef32dLE ptr' rxx >> pokef32dLE ptr' rxy >> pokef32dLE ptr' rxz+			pokef32dLE ptr' ryx >> pokef32dLE ptr' ryy >> pokef32dLE ptr' ryz+			pokef32dLE ptr' rzx >> pokef32dLE ptr' rzy >> pokef32dLE ptr' rzz++			pokef32dLE ptr' px >> pokef32dLE ptr' py >> pokef32dLE ptr' pz++			pokei32LE ptr' p0+			pokei32LE ptr' p1++		where ptr' = castPtr ptr++instance Storable Ball where+	sizeOf    ~(Ball (Vec3 _px _py _pz) _r) = sum [3 * sizeOf x', sizeOf x']+		where x' = error "Internal error: sizeOf Ball: sizeOf accessed its argument!" :: Float+	alignment ~(Ball (Vec3 _px _py _pz) _r) = max 1 $ maximum [alignment x', alignment x']+		where x' = error "Internal error: alignment Ball: alignment accessed its argument!" :: Float+	peek ptr = flip evalStateT 0 $ Ball <$> (Vec3 <$> peekf32dLE ptr' <*> peekf32dLE ptr' <*> peekf32dLE ptr') <*> peekf32dLE ptr'+		where ptr' = castPtr ptr+	poke ptr (Ball (Vec3 px py pz) r) = flip evalStateT 0 $ pokef32dLE ptr' px >> pokef32dLE ptr' py >> pokef32dLE ptr' pz >> pokef32dLE ptr' r+		where ptr' = castPtr ptr++instance Storable View where+	sizeOf    ~(View (Vec3 _px _py _pz) (Vec3 _qx _qy _qz)) = sum [3 * sizeOf x', 3 * sizeOf x']+		where x' = error "Internal error: sizeOf View: sizeOf accessed its argument!" :: Float+	alignment ~(View (Vec3 _px _py _pz) (Vec3 _qx _qy _qz)) = max 1 $ maximum [alignment x', alignment x']+		where x' = error "Internal error: alignment View: alignment accessed its argument!" :: Float+	peek ptr = flip evalStateT 0 $ View <$> (Vec3 <$> peekf32dLE ptr' <*> peekf32dLE ptr' <*> peekf32dLE ptr') <*> (Vec3 <$> peekf32dLE ptr' <*> peekf32dLE ptr' <*> peekf32dLE ptr')+		where ptr' = castPtr ptr+	poke ptr (View (Vec3 px py pz) (Vec3 qx qy qz)) = flip evalStateT 0 $ pokef32dLE ptr' px >> pokef32dLE ptr' py >> pokef32dLE ptr' pz >> pokef32dLE ptr' qx >> pokef32dLE ptr' qy >> pokef32dLE ptr' qz+		where ptr' = castPtr ptr++instance Storable Dict where+	sizeOf    ~(Dict ai aj) = sum [sizeOf ai, sizeOf aj]+	alignment ~(Dict ai aj) = max 1 $ maximum [alignment ai, alignment aj]+	peek ptr = flip evalStateT 0 $ Dict <$> peeki32LE ptr' <*> peeki32LE ptr'+		where ptr' = castPtr ptr+	poke ptr (Dict ai aj) = flip evalStateT 0 $ pokei32LE ptr' ai >> pokei32LE ptr' aj+		where ptr' = castPtr ptr
+ Immutaball/Share/Level/Parser.hs view
@@ -0,0 +1,582 @@+{-# 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/Parser.hs.++{-# LANGUAGE Haskell2010 #-}+{-# LANGUAGE ScopedTypeVariables, NondecreasingIndentation, ExistentialQuantification #-}++module Immutaball.Share.Level.Parser+	(+		-- * parsing+		parseLevelFile,+		levelFileParser,+		levelFileParser',+		parseByte,+		parsei32Native,+		parsei32BE,+		parsei32LE,+		parsef32dLE,+		parsen,+		parseCString,+		parseVec2fd,+		parseVec3fd,+		parseVec4fd,++		parseDict,+		parseMtrl,+		parseVert,+		parseEdge,+		parseSide,+		parseTexc,+		parseOffs,+		parseGeom,+		parseLump,+		parseNode,+		parsePath,+		parseBody,+		parseItem,+		parseGoal,+		parseJump,+		parseSwch,+		parseBill,+		parseBall,+		parseView,++		-- * optional low-level parsing+		unsafeParseLevelFileRaw,+		w32ToFloat,++		-- * exceptions+		LevelIBParseException(..),+		levelIBParseExceptionToException,+		levelIBParseExceptionFromException,+		UndersizedLevelIBParseException(..),+		MissingSOLMagicIBParseException(..),+		UnsupportedSOLVersionIBParseException(..),+		OversizedLevelIBParseException(..),+		ParseErrorLevelIBParseException(..)+	) where++import Prelude ()+import Immutaball.Prelude++import Control.Arrow+import Control.Exception+import Control.Lens+import Control.Monad+import Data.Bits+import Data.Coerce+import Data.Function hiding (id, (.))+import Data.Int+import Data.Typeable+import Data.Word+import Foreign.C.Types+import Foreign.ForeignPtr+import Foreign.Ptr+import Foreign.Storable+import Text.Printf++import Data.Array+import Data.Array.IArray as IA+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BL+import qualified SDL.Raw.Enum as Raw+import Text.Parsec as P++import Immutaball.Share.Level.Base+import Immutaball.Share.Math+import Immutaball.Share.Utils++-- Low-level imports.+import System.IO.Unsafe (unsafePerformIO)+import qualified Data.ByteString.Unsafe as UB++-- * optional low-level parsing++-- | Uses low-level memory management.+--+-- It does _some_ length checking but still does some memory reading without+-- checking for length of the input data (and only afterward reading).+--+-- We don't use this.+unsafeParseLevelFileRaw :: String -> BS.ByteString -> Either LevelIBParseException LevelIB+unsafeParseLevelFileRaw inputName inputContents+	| inputSize < lengthSolSize =+		Left . errSize $ "Error: parseLevelFile: the data string does not have enough data to read the header with lengths!"+	| otherwise = unsafePerformIO $+		UB.unsafeUseAsCString inputContents $ \inputPtr_ -> do+			let (inputPtr :: Ptr Sol) = castPtr inputPtr_+			(lengthSol :: Sol) <- peekSolLengths inputPtr++			-- Check magic.+			if' ((lengthSol^.solMagic)   /= solMagicConstant) (return . Left . errMagic   $ printf "Error: parseLevelFile: input ‘%s’ is missing the 4 SOL magic bytes.  Is it a SOL file?  0x%04X /= 0x%04X." inputName (lengthSol^.solMagic) solMagicConstant) $ do++			-- Check version.+			if' ((lengthSol^.solVersion) /= solVersionCurr)   (return . Left . errVersion $ printf "Error: parseLevelFile: SOL file input ‘%s’ has an unsupported version.  Its code %d /= %d." inputName (lengthSol^.solVersion) solVersionCurr) $ do++			-- Now we know the lengths, so we can calculate the size of the data we require.+			let neededSizeMin = sizeOfExistingSolMin lengthSol+			let neededSizeMax = sizeOfExistingSolMax lengthSol+			let actualSize = inputSize+			if' (actualSize < neededSizeMin) (return . Left . errSize $ printf "Error: parseLevelFile: we parsed the lengths, but the data is too small to parse the file: input ‘%s’ has size %d < %d" inputName inputSize neededSizeMin) $ do++			-- Also check for oversize.+			if' (actualSize > neededSizeMax) (return . Left . errBigSize $ printf "Error: parseLevelFile: we parsed the lengths, but the data is larger than expected: input ‘%s’ has size %d > %d; recommend aborting in case data is corrupted" inputName inputSize neededSizeMax) $ do++			-- Now parse the sol now that we validated the size.+			-- This is unsafe since we don't know if we have enough data, but we at least know we're somewhat within the bounds.+			sol <- peekSol inputPtr++			-- Now check the exact length.+			let neededSize = sizeOfExistingSol sol+			if' (actualSize < neededSize) (return . Left . errSize $ printf "Error: parseLevelFile: we parsed the lengths, but the data is too small to parse the file (exact size): input ‘%s’ has size %d < %d" inputName inputSize neededSize) $ do+			if' (actualSize > neededSize) (return . Left . errBigSize $ printf "Error: parseLevelFile: we parsed the lengths, but the data is larger than expected (exact size): input ‘%s’ has size %d > %d; recommend aborting in case data is corrupted" inputName inputSize neededSize) $ do++			-- Return our parsed Sol.+			return $ Right sol+	where+		lengthSolSize :: Int+		lengthSolSize = sizeOfEmptySol emptySol+		inputSize = BS.length inputContents+		errSize = LevelIBParseException . UndersizedLevelIBParseException+		errBigSize = LevelIBParseException . OversizedLevelIBParseException+		errMagic = LevelIBParseException . MissingSOLMagicIBParseException+		errVersion = LevelIBParseException . UnsupportedSOLVersionIBParseException++w32ToFloat :: Word32 -> Float+w32ToFloat w32 = unsafePerformIO $ do+	-- GHC doesn't support coerce between Word32 and Float.+	-- Just malloc a new cfloat.+	{-+	let (f32 :: Float)  = coerce w32+	-}+	(cfloat :: ForeignPtr CFloat) <- mallocForeignPtr+	(cf32 :: CFloat) <- withForeignPtr cfloat $ \cfloatPtr -> poke (castPtr cfloatPtr) w32 >> peek cfloatPtr+	let (f32 :: Float) = coerce cf32+	return f32++-- * exceptions++data LevelIBParseException = forall e. Exception e => LevelIBParseException e+instance Show LevelIBParseException where+	show (LevelIBParseException e) = show e+instance Exception LevelIBParseException+levelIBParseExceptionToException :: Exception e => e -> SomeException+levelIBParseExceptionToException = toException . LevelIBParseException+levelIBParseExceptionFromException :: Exception e => SomeException -> Maybe e+levelIBParseExceptionFromException x = do+	LevelIBParseException a <- fromException x+	cast a++-- | The input data was not big enough.+data UndersizedLevelIBParseException = UndersizedLevelIBParseException String+instance Exception UndersizedLevelIBParseException where+	toException = levelIBParseExceptionToException+	fromException = levelIBParseExceptionFromException+instance Show UndersizedLevelIBParseException where+	show (UndersizedLevelIBParseException msg) = msg++-- | The file does not start with the 4 SOL magic bytes.+data MissingSOLMagicIBParseException = MissingSOLMagicIBParseException String+instance Exception MissingSOLMagicIBParseException where+	toException = levelIBParseExceptionToException+	fromException = levelIBParseExceptionFromException+instance Show MissingSOLMagicIBParseException where+	show (MissingSOLMagicIBParseException msg) = msg++-- | The SOL version is not supported.+data UnsupportedSOLVersionIBParseException = UnsupportedSOLVersionIBParseException String+instance Exception UnsupportedSOLVersionIBParseException where+	toException = levelIBParseExceptionToException+	fromException = levelIBParseExceptionFromException+instance Show UnsupportedSOLVersionIBParseException where+	show (UnsupportedSOLVersionIBParseException msg) = msg++-- | The input data was bigger than expected.+data OversizedLevelIBParseException = OversizedLevelIBParseException String+instance Exception OversizedLevelIBParseException where+	toException = levelIBParseExceptionToException+	fromException = levelIBParseExceptionFromException+instance Show OversizedLevelIBParseException where+	show (OversizedLevelIBParseException msg) = msg++-- | The input data was bigger than expected.+data ParseErrorLevelIBParseException = ParseErrorLevelIBParseException ParseError+instance Exception ParseErrorLevelIBParseException where+	toException = levelIBParseExceptionToException+	fromException = levelIBParseExceptionFromException+instance Show ParseErrorLevelIBParseException where+	show (ParseErrorLevelIBParseException parseError) = show parseError++-- * parsing++parseLevelFile :: String -> BL.ByteString -> Either LevelIBParseException LevelIB+parseLevelFile inputName inputContents = LevelIBParseException . ParseErrorLevelIBParseException +++ id $ parse levelFileParser inputName inputContents++parseByte :: Parsec BL.ByteString () Word8+parseByte = truncateAsciiChar <$> anyChar+	& P.try <?> "parseByte expected a w8"+	where+		truncateAsciiChar :: Char -> Word8+		truncateAsciiChar = toEnum . fromEnum++parsei32Native :: Parsec BL.ByteString () Int32+parsei32Native = (<?> "parsei32Native expected an i32") . P.try $ do+	byte0_ <- parseByte+	byte1_ <- parseByte+	byte2_ <- parseByte+	byte3_ <- parseByte+	let (byte0, byte1, byte2, byte3) = if' (Raw.SDL_BYTEORDER == Raw.SDL_BIG_ENDIAN) (byte0_, byte1_, byte2_, byte3_) (byte3_, byte2_, byte1_, byte0_)+	let (w32 :: Word32) = ((fromIntegral byte0 `shiftL` 24) .|. (fromIntegral byte1 `shiftL` 16) .|. (fromIntegral byte2 `shiftL` 8) .|. (fromIntegral byte3 `shiftL` 0))+	let (i32 :: Int32)  = fromIntegral w32+	return $ i32++parsei32BE :: Parsec BL.ByteString () Int32+parsei32BE = (<?> "parsei32BE expected an i32") . P.try $ do+	byte0 <- parseByte+	byte1 <- parseByte+	byte2 <- parseByte+	byte3 <- parseByte+	let (w32 :: Word32) = ((fromIntegral byte0 `shiftL` 24) .|. (fromIntegral byte1 `shiftL` 16) .|. (fromIntegral byte2 `shiftL` 8) .|. (fromIntegral byte3 `shiftL` 0))+	let (i32 :: Int32)  = fromIntegral w32+	return $ i32++parsei32LE :: Parsec BL.ByteString () Int32+parsei32LE = (<?> "parsei32LE expected an i32") . P.try $ do+	byte3 <- parseByte+	byte2 <- parseByte+	byte1 <- parseByte+	byte0 <- parseByte+	let (w32 :: Word32) = ((fromIntegral byte0 `shiftL` 24) .|. (fromIntegral byte1 `shiftL` 16) .|. (fromIntegral byte2 `shiftL` 8) .|. (fromIntegral byte3 `shiftL` 0))+	let (i32 :: Int32)  = fromIntegral w32+	return $ i32++parsef32dLE :: Parsec BL.ByteString () Double+parsef32dLE = (<?> "parsef32dLE expected an f32") . P.try $ do+	byte3 <- parseByte+	byte2 <- parseByte+	byte1 <- parseByte+	byte0 <- parseByte+	let (w32 :: Word32) = ((fromIntegral byte0 `shiftL` 24) .|. (fromIntegral byte1 `shiftL` 16) .|. (fromIntegral byte2 `shiftL` 8) .|. (fromIntegral byte3 `shiftL` 0))+	let (fl  :: Float)  = w32ToFloat w32+	let (d   :: Double) = realToFrac fl+	return $ d++parsen :: forall a. Parsec BL.ByteString () a -> Int32 -> Parsec BL.ByteString () (Array Int32 a)+parsen parseElem n+	| n <= 0 = return emptyArray+	| otherwise = (<?> (printf "parsen _ %d expected an array" n)) . P.try $ do+		as <- flip fix 0 $ \me idx -> do+			if' (idx >= n) (return []) $ do+			a <- parseElem+			(a:) <$> me (idx+1)+		return $ IA.listArray (0, n-1) as+	where+		emptyArray :: Array Int32 a+		emptyArray = IA.listArray (0, -1) []++parseCString :: Int -> Parsec BL.ByteString () String+parseCString n+	| n <= 0 = return []+	| otherwise = (<?> (printf "parseCString %d expected a CString" n)) . P.try $ do+		cs <- (\me -> me 0 False) . fix $ \me idx isTerminated -> do+			if' (idx >= n) (return []) $ do+			b <- parseByte+			let c = asciiChar b+			if' (isTerminated || b == 0) (me (idx+1) True) $ do+			(c:) <$> me (idx+1) isTerminated+		let str = cs+		return $ str+	where+		asciiChar :: Word8 -> Char+		asciiChar = toEnum . fromEnum++parseVec2fd :: Parsec BL.ByteString () (Vec2 Double)+parseVec2fd = Vec2 <$> parsef32dLE <*> parsef32dLE+	& P.try <?> "parseVec2fd expected a Vec2f"++parseVec3fd :: Parsec BL.ByteString () (Vec3 Double)+parseVec3fd = Vec3 <$> parsef32dLE <*> parsef32dLE <*> parsef32dLE+	& P.try <?> "parseVec3fd expected a Vec3f"++parseVec4fd :: Parsec BL.ByteString () (Vec4 Double)+parseVec4fd = Vec4 <$> parsef32dLE <*> parsef32dLE <*> parsef32dLE <*> parsef32dLE+	& P.try <?> "parseVec4fd expected a Vec4f"++levelFileParser :: Parsec BL.ByteString () LevelIB+levelFileParser = levelFileParser' True++levelFileParser' :: Bool -> Parsec BL.ByteString () LevelIB+levelFileParser' isEof = (<?> "levelFileParser expected a sol") . P.try $ do+	magic   <- parsei32LE & P.try <?> "levelFileParser expected magic"+	when (magic   /= solMagicConstant) . unexpected $ printf "Error: levelFileParser: expected the 4 SOL starter bytes; found 0x%04X, /= 0x%04X" magic solMagicConstant+	version <- parsei32LE & P.try <?> "levelFileParser expected version"+	when (version /= solVersionCurr  ) . unexpected $ printf "Error: levelFileParser: unsupported SOL version; found %d, /= %d" version solVersionCurr++	ac <- parsei32LE & P.try <?> "levelFileParser expected ac"+	dc <- parsei32LE & P.try <?> "levelFileParser expected dc"+	mc <- parsei32LE & P.try <?> "levelFileParser expected mc"+	vc <- parsei32LE & P.try <?> "levelFileParser expected vc"+	ec <- parsei32LE & P.try <?> "levelFileParser expected ec"+	sc <- parsei32LE & P.try <?> "levelFileParser expected sc"+	tc <- parsei32LE & P.try <?> "levelFileParser expected tc"+	oc <- parsei32LE & P.try <?> "levelFileParser expected oc"+	gc <- parsei32LE & P.try <?> "levelFileParser expected gc"+	lc <- parsei32LE & P.try <?> "levelFileParser expected lc"+	nc <- parsei32LE & P.try <?> "levelFileParser expected nc"+	pc <- parsei32LE & P.try <?> "levelFileParser expected pc"+	bc <- parsei32LE & P.try <?> "levelFileParser expected bc"+	hc <- parsei32LE & P.try <?> "levelFileParser expected hc"+	zc <- parsei32LE & P.try <?> "levelFileParser expected zc"+	jc <- parsei32LE & P.try <?> "levelFileParser expected jc"+	xc <- parsei32LE & P.try <?> "levelFileParser expected xc"+	rc <- parsei32LE & P.try <?> "levelFileParser expected rc"+	uc <- parsei32LE & P.try <?> "levelFileParser expected uc"+	wc <- parsei32LE & P.try <?> "levelFileParser expected wc"+	ic <- parsei32LE & P.try <?> "levelFileParser expected ic"++	av <- parsen parseByte  ac & (fmap (coerce . (fromIntegral :: Word8 -> Int8)) <$>) & P.try <?> "levelFileParser expected av"+	dv <- parsen parseDict  dc & P.try <?> "levelFileParser expected dv"+	mv <- parsen parseMtrl  mc & P.try <?> "levelFileParser expected mv"+	vv <- parsen parseVert  vc & P.try <?> "levelFileParser expected vv"+	ev <- parsen parseEdge  ec & P.try <?> "levelFileParser expected ev"+	sv <- parsen parseSide  sc & P.try <?> "levelFileParser expected sv"+	tv <- parsen parseTexc  tc & P.try <?> "levelFileParser expected tv"+	ov <- parsen parseOffs  oc & P.try <?> "levelFileParser expected ov"+	gv <- parsen parseGeom  gc & P.try <?> "levelFileParser expected gv"+	lv <- parsen parseLump  lc & P.try <?> "levelFileParser expected lv"+	nv <- parsen parseNode  nc & P.try <?> "levelFileParser expected nv"+	pv <- parsen parsePath  pc & P.try <?> "levelFileParser expected pv"+	bv <- parsen parseBody  bc & P.try <?> "levelFileParser expected bv"+	hv <- parsen parseItem  hc & P.try <?> "levelFileParser expected hv"+	zv <- parsen parseGoal  zc & P.try <?> "levelFileParser expected zv"+	jv <- parsen parseJump  jc & P.try <?> "levelFileParser expected jv"+	xv <- parsen parseSwch  xc & P.try <?> "levelFileParser expected xv"+	rv <- parsen parseBill  rc & P.try <?> "levelFileParser expected rv"+	uv <- parsen parseBall  uc & P.try <?> "levelFileParser expected uv"+	wv <- parsen parseView  wc & P.try <?> "levelFileParser expected wv"+	iv <- parsen parsei32LE ic & P.try <?> "levelFileParser expected iv"++	if' isEof eof (pure ()) & P.try <?> "levelFileParser expected end of input."++	return $ Sol {+		_solMagic   = magic,+		_solVersion = version,++		_solAc = ac,+		_solDc = dc,+		_solMc = mc,+		_solVc = vc,+		_solEc = ec,+		_solSc = sc,+		_solTc = tc,+		_solOc = oc,+		_solGc = gc,+		_solLc = lc,+		_solNc = nc,+		_solPc = pc,+		_solBc = bc,+		_solHc = hc,+		_solZc = zc,+		_solJc = jc,+		_solXc = xc,+		_solRc = rc,+		_solUc = uc,+		_solWc = wc,+		_solIc = ic,++		_solAv = av,+		_solDv = dv,+		_solMv = mv,+		_solVv = vv,+		_solEv = ev,+		_solSv = sv,+		_solTv = tv,+		_solOv = ov,+		_solGv = gv,+		_solLv = lv,+		_solNv = nv,+		_solPv = pv,+		_solBv = bv,+		_solHv = hv,+		_solZv = zv,+		_solJv = jv,+		_solXv = xv,+		_solRv = rv,+		_solUv = uv,+		_solWv = wv,+		_solIv = iv+	}++parseDict :: Parsec BL.ByteString () Dict+parseDict = Dict <$> parsei32LE <*> parsei32LE+	& P.try <?> "parseDict expected a Dict"++parseMtrl :: Parsec BL.ByteString () Mtrl+parseMtrl = (<?> "parsePath expected a Path") . P.try $ do+	d <- parseVec4fd+	a <- parseVec4fd+	s <- parseVec4fd+	e <- parseVec4fd+	h <- parsef32dLE++	let angle = 0.0++	fl <- parsei32LE++	f <- parseCString solPathMax++	alphaFunc <- if' ((fl .&. mtrlFlagAlphaTest) /= 0) parsei32LE  (pure 0  )+	alphaRef  <- if' ((fl .&. mtrlFlagAlphaTest) /= 0) parsef32dLE (pure 0.0)++	return $ Mtrl {+		_mtrlD = d,+		_mtrlA = a,+		_mtrlS = s,+		_mtrlE = e,+		_mtrlH = h,++		_mtrlAngle = angle,++		_mtrlFl = fl,+		_mtrlF  = f,++		_mtrlAlphaFunc = alphaFunc,+		_mtrlAlphaRef  = alphaRef+	}++parseVert :: Parsec BL.ByteString () Vert+parseVert = Vert <$> parseVec3fd+	& P.try <?> "parseVert expected a Vert"++parseEdge :: Parsec BL.ByteString () Edge+parseEdge = Edge <$> parsei32LE <*> parsei32LE+	& P.try <?> "parseEdge expected an Edge"++parseSide :: Parsec BL.ByteString () Side+parseSide = Side <$> parseVec3fd <*> parsef32dLE+	& P.try <?> "parseSide expected a Side"++parseTexc :: Parsec BL.ByteString () Texc+parseTexc = Texc <$> parseVec2fd+	& P.try <?> "parseTexc expected a Texc"++parseOffs :: Parsec BL.ByteString () Offs+parseOffs = Offs <$> parsei32LE <*> parsei32LE <*> parsei32LE+	& P.try <?> "parseOffs expected an Offs"++parseGeom :: Parsec BL.ByteString () Geom+parseGeom = Geom <$> parsei32LE <*> parsei32LE <*> parsei32LE <*> parsei32LE+	& P.try <?> "parseGeom expected a Geom"++parseLump :: Parsec BL.ByteString () Lump+parseLump = Lump <$> parsei32LE <*> parsei32LE <*> parsei32LE <*> parsei32LE <*> parsei32LE <*> parsei32LE <*> parsei32LE <*> parsei32LE <*> parsei32LE+	& P.try <?> "parseLump expected a Lump"++parseNode :: Parsec BL.ByteString () Node+parseNode = Node <$> parsei32LE <*> parsei32LE <*> parsei32LE <*> parsei32LE <*> parsei32LE+	& P.try <?> "parseNode expected a Node"++-- Irregular encoding.+parsePath :: Parsec BL.ByteString () Path+parsePath = (<?> "parsePath expected a Path") . P.try $ do+	p   <- parseVec3fd+	t   <- parsef32dLE+	pi_ <- parsei32LE+	f   <- parsei32LE+	s   <- parsei32LE+	fl  <- parsei32LE++	e        <- if' ((fl .&. pathFlagOriented) /= 0) parseVec4fd (return $ Vec4 0.0 0.0 0.0 0.0)+	(p0, p1) <- if' ((fl .&. pathFlagParented) /= 0) ((,) <$> parsei32LE <*> parsei32LE) (return $ (0, 0))++	let tm = round $ (1000.0*t)++	let p1' = if' (p1 < 0) p0 p1++	return $ Path {+		_pathP  = p,+		_pathE  = e,+		_pathT  = t,+		_pathTm = tm,++		_pathPi = pi_,+		_pathF  = f,+		_pathS  = s,++		_pathFl = fl,++		_pathP0 = p0,+		_pathP1 = p1'+	}++parseBody :: Parsec BL.ByteString () Body+parseBody = Body <$> parsei32LE <*> parsei32LE <*> parsei32LE <*> parsei32LE <*> parsei32LE <*> parsei32LE <*> parsei32LE+	& P.try <?> "parseBody expected a Body"++parseItem :: Parsec BL.ByteString () Item+parseItem = (((\item -> item & (itemP1 .~ (if' (item^.itemP1 < 0) (item^.itemP0) (item^.itemP1)))) <$>) $ Item <$>+	parseVec3fd <*> parsei32LE <*> parsei32LE <*> parsei32LE <*> parsei32LE)+	& P.try <?> "parseItem expected an Item"++parseGoal :: Parsec BL.ByteString () Goal+parseGoal = (((\goal -> goal & (goalP1 .~ (if' (goal^.goalP1 < 0) (goal^.goalP0) (goal^.goalP1)))) <$>) $ Goal <$>+	parseVec3fd <*> parsef32dLE <*> parsei32LE <*> parsei32LE)+	& P.try <?> "parseGoal expected a Goal"++parseJump :: Parsec BL.ByteString () Jump+parseJump = (((\jump -> jump & (jumpP1 .~ (if' (jump^.jumpP1 < 0) (jump^.jumpP0) (jump^.jumpP1)))) <$>) $ Jump <$>+	parseVec3fd <*> parseVec3fd <*> parsef32dLE <*> parsei32LE <*> parsei32LE)+	& P.try <?> "parseJump expected a Jump"++-- Irregular encoding.+parseSwch :: Parsec BL.ByteString () Swch+parseSwch = (<?> "parseSwch expected a Swch") . P.try $ do+	p   <- parseVec3fd+	r   <- parsef32dLE+	pi_ <- parsei32LE++	t      <- parsef32dLE+	_skip0 <- parsef32dLE+	let tm = round $ 1000.0*t+	f      <- parsei32LE+	_skip1 <- parsei32LE+	i      <- parsei32LE++	p0 <- parsei32LE+	p1 <- parsei32LE++	let p1' = if' (p1 < 0) p0 p1++	return $ Swch {+		_swchP  = p,+		_swchR  = r,+		_swchPi = pi_,++		_swchT  = t,+		_swchTm = tm,+		_swchF  = f,+		_swchI  = i,++		_swchP0 = p0,+		_swchP1 = p1'+	}++parseBill :: Parsec BL.ByteString () Bill+parseBill = (((\bill -> bill & (billP1 .~ (if' (bill^.billP1 < 0) (bill^.billP0) (bill^.billP1)))) <$>) $ Bill <$>+	parsei32LE <*> parsei32LE <*> parsef32dLE <*> parsef32dLE <*>+	parseVec3fd <*> parseVec3fd <*>+	parseVec3fd <*> parseVec3fd <*> parseVec3fd <*>+	parseVec3fd <*>+	parsei32LE <*> parsei32LE)+	& P.try <?> "parseBill expected a Bill"++parseBall :: Parsec BL.ByteString () Ball+parseBall = Ball <$> parseVec3fd <*> parsef32dLE+	& P.try <?> "parseBall expected a Ball"++parseView :: Parsec BL.ByteString () View+parseView = View <$> parseVec3fd <*> parseVec3fd+	& P.try <?> "parseView expected a View"
+ Immutaball/Share/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 #-}++-- | 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
@@ -0,0 +1,74 @@+{-# 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/Utils.hs.++{-# LANGUAGE Haskell2010 #-}++module Immutaball.Share.Level.Utils+	(+		postprocessSol,+		miscProcessSol,+		transformSol,+		restoreSolTransformation,+		restoreSolTransformationSimple,+		mapcSolTransformationSimple+	) where++import Prelude ()+import Immutaball.Prelude++import Control.Lens++import Immutaball.Share.Level.Base+import Immutaball.Share.Math+import Immutaball.Share.Utils++-- | ‘transformSol’ and ‘miscProcessSol’.+postprocessSol :: Mat4 Double -> Sol -> Sol+postprocessSol m sol = miscProcessSol . transformSol m $ sol++-- | Replace ‘default’ with ‘mtrl/invisible’ for all mtrl paths.+miscProcessSol :: Sol -> Sol+miscProcessSol sol = sol &+	(solMv %~ fmap (mtrlF %~ (\p -> if' (p /= "default") p "mtrl/invisible")))++-- | Apply a transformation to all positions in a Sol.+--+-- TODO: apply transformation to path E orientation, which is a quaternion.+transformSol :: Mat4 Double -> Sol -> Sol+transformSol m sol = sol &+	(solVv %~ fmap (vertP %~ m4v3 m)) &+	(solPv %~ fmap (pathP %~ m4v3 m)) &+	-- TODO:+	--(solPv %~ fmap (pathE %~ (\q -> (\v -> (qasv4.~v) & q) . TODO . mv4 m . rotate3 . qToSr . (^.qasv4) $ q))) &  -- Convert quaternion rotation to rotation matrix, mat mul, then convert back to quaternion.+	(solHv %~ fmap (itemP %~ m4v3 m)) &+	(solZv %~ fmap (goalP %~ m4v3 m)) &+	(solJv %~ fmap (jumpP %~ m4v3 m)) &+	(solJv %~ fmap (jumpQ %~ m4v3 m)) &+	(solXv %~ fmap (swchP %~ m4v3 m)) &+	(solUv %~ fmap (ballP %~ m4v3 m)) &+	(solWv %~ fmap (viewP %~ m4v3 m)) &+	(solWv %~ fmap (viewQ %~ m4v3 m)) &+	id++-- | Invert mapc's swapping of y and z axes and negation to in terms I like to+-- think of in more; glFrustrum can be combined with a transformation.+restoreSolTransformation :: Mat4 Double+restoreSolTransformation = m3to4 $ restoreSolTransformationSimple++-- | Invert 'mapcSolTransformationSimple'.+--+-- This does not include the scaling by 1/64, which is preserved.+restoreSolTransformationSimple :: Mat3 Double+restoreSolTransformationSimple = Mat3 $ Vec3+	(Vec3 1.0 0.0 0.0   )+	(Vec3 0.0 0.0 (-1.0))+	(Vec3 0.0 1.0 0.0   )++mapcSolTransformationSimple :: Mat3 Double+mapcSolTransformationSimple = Mat3 $ Vec3+	(Vec3 1.0 0.0    0.0)+	(Vec3 0.0 0.0    1.0)+	(Vec3 0.0 (-1.0) 0.0)
+ Immutaball/Share/Math.hs view
@@ -0,0 +1,20 @@+{-# 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 #-}++-- State.hs.++{-# LANGUAGE Haskell2010 #-}++-- | Includes our Math modules.+module Immutaball.Share.Math+	(+		module Immutaball.Share.Math.Core,+		module Immutaball.Share.Math.X3D+	) where++import Prelude ()+--import Immutaball.Prelude++import Immutaball.Share.Math.Core+import Immutaball.Share.Math.X3D
+ Immutaball/Share/Math/Core.hs view
@@ -0,0 +1,2087 @@+{-# 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 #-}++-- State.hs.++{-# LANGUAGE Haskell2010 #-}+{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, InstanceSigs, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances, FlexibleContexts #-}++-- | 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.+module Immutaball.Share.Math.Core+	(+		Vec2(..), x2, y2,+		rv2,+		pv2,+		sv2,+		minusv2,+		d2,+		co2,+		fr2,+		cm2,+		r2,+		t2,+		Vec3(..), x3, y3, z3,+		pv3,+		sv3,+		minusv3,+		d3,+		co3,+		fr3,+		cm3,+		r3,+		Vec4(..), x4, y4, z4, w4,+		rv4,+		pv4,+		sv4,+		minusv4,+		d4,+		co4,+		fr4,+		cm4,+		r4,+		Mat3(..), getMat3,+		Mat4(..), getMat4,+		r0_3,+		r1_3,+		r2_3,+		r0_4,+		r1_4,+		r2_4,+		r3_4,+		transposeMat3,+		transposeMat4,+		e0_0_4, e0_1_4, e0_2_4, e0_3_4,+		e1_0_4, e1_1_4, e1_2_4, e1_3_4,+		e2_0_4, e2_1_4, e2_2_4, e2_3_4,+		e3_0_4, e3_1_4, e3_2_4, e3_3_4,+		e0_0_3, e0_1_3, e0_2_3,+		e1_0_3, e1_1_3, e1_2_3,+		e2_0_3, e2_1_3, e2_2_3,+		mm3,+		mm4,+		c0_3,+		c1_3,+		c2_3,+		c0_4,+		c1_4,+		c2_4,+		c3_4,+		v3normalize,+		v3magnitude,+		v4normalize,+		v4magnitude,+		identity3,+		identity4,+		Rect(..), rectp1, rectp2,+		rectLowerLeft,+		rectUpperRight,+		rectCenter,+		rectTop,+		rectRight,+		rectBottom,+		rectLeft,+		rectUpperLeft,+		rectLowerRight,+		rectWidthAboutCenter,+		rectHeightAboutCenter,+		rectAvgSideAboutCenter,+		rectNormalize,+		isInRect,+		isInRect',+		lerpWith,+		lerp,+		lerpV2,+		lerpV3,+		lerpV4,+		ilerpWith,+		ilerp,+		tau,++		WidthHeightI,++		v4to3,+		v3to4,+		mv3,+		m4v3,+		mv4,+		vm3,+		vm4,+		v3m4,+		v2or,+		v2orWith,+		v3or,+		v3orWith,+		vx3,+		v2perp,+		v3perp,++		SimpleRotation(..), srCcwAngle, srOriginAxis,+		Quaternion(..), qReal, qVector,+		qasv4,+		sq,+		pq,+		mq,+		qmi,+		qq,+		v3q,+		qcv3,+		srToQ,+		qnormalize,+		qmagnitude,+		qToSr,+		srToVec3,+		v3ToSr,+		simpleRotate,+		m3to4,+		scale3,+		scale3Simple,+		scale4,+		translate3,+		tilt3z,+		tilt3zSimple,+		tilt3zReverse,+		tilt3zReverseSimple,+		tilt3y,+		tilt3ySimple,+		tilt3yReverse,+		tilt3yReverseSimple,+		rotate3,+		rotate3Simple,+		rotate3Simple_,+		identityTransformation3,+		identityTransformation3Simple,+		rotatexy,+		rotatexz,+		rotateyz,+		rotatexySimple,+		rotatexzSimple,+		rotateyzSimple,+		determinant4,+		determinant3,+		smalld,+		smallf,+		SmallNum(..),+		equivalentSmall,+		eq2,+		eq3,+		eq4,+		eqm3,+		eqm4,+		smallishd,+		smallishf,+		SmallishNum(..),+		near,+		near2,+		near3,+		near4,+		nearm3,+		nearm4,+		rankNonzerov4,+		rankNonzerov3,+		inversem4,+		inversem3,+		inversem4GaussianElimination,+		inversem3GaussianElimination,+		perspective,+		perspectivePure,+		fov,+		fovPure,++		zv2,+		zv3,+		zv4,+		rm3,+		rm4,+		zm3,+		zm4,++		MView,+		MViewd,+		MView'(..), mviewPos, mviewTarget, mviewFov,+		viewMat,+		viewMat',+		worldToGL,+		worldToGLSimple,+		rescaleDepth,++		-- * 3D vector aiming rotation utils in radians: horizontal and vertical aiming of a point relative to origin.++		aimHoriz3DSimple,+		aimVert3DSimple,++		-- * More utils.+		v2z,+		v2s,+		v2nzElse,+		v2nsElse,+		v3z,+		v3s,+		v3nzElse,+		v3nsElse,+		v4z,+		v4s,+		v4nzElse,+		v4nsElse,++		-- * Subvectors.+		xy3,+		xz3,+		yz3,+		xy4,+		xz4,+		xw4,+		yz4,+		yw4,+		zw4,+		xyz4,+		xyw4,+		xzw4,+		yzw4,++		sqx+	) where++import Prelude ()+import Immutaball.Prelude++import Control.Arrow+import Control.Monad+import Data.Maybe++import Control.Lens++import Immutaball.Share.Utils++data Vec2 a = Vec2 {+	_x2 :: a,+	_y2 :: a+}+	deriving (Eq, Ord, Show)+makeLenses ''Vec2++instance Functor Vec2 where+	fmap :: (a -> b) -> (Vec2 a -> Vec2 b)+	fmap f (Vec2 x y) = Vec2 (f x) (f y)++instance Field1 (Vec2 a) (Vec2 a) a a where _1 = x2+instance Field2 (Vec2 a) (Vec2 a) a a where _2 = y2++instance Applicative Vec2 where+	pure :: a -> Vec2 a+	pure = rv2+	(<*>) :: Vec2 (a -> b) -> Vec2 a -> Vec2 b+	(Vec2 fx fy) <*> (Vec2 x y) = Vec2 (fx x) (fy y)++-- | Component-wise multiplication and abs instance.+instance (Num a) => Num (Vec2 a) where+	(+) = pv2+	(-) = minusv2+	fromInteger = rv2 . fromInteger+	abs = fmap abs+	(*) = cm2+	signum = fmap signum++rv2 :: a -> Vec2 a+rv2 z = Vec2 z z++pv2 :: (Num a) => Vec2 a -> Vec2 a -> Vec2 a+pv2 (Vec2 ax ay) (Vec2 bx by) = Vec2 (ax + bx) (ay + by)++sv2 :: (Num a) => a -> Vec2 a -> Vec2 a+sv2 s (Vec2 x y) = Vec2 (s*x) (s*y)++minusv2 :: (Num a) => Vec2 a -> Vec2 a -> Vec2 a+minusv2 (Vec2 ax ay) (Vec2 bx by) = Vec2 (ax - bx) (ay - by)++-- | Polar coordinates.+r2 :: forall a. (RealFloat a) => Lens' (Vec2 a) a+r2 = lens getter (flip setter)+	where+		getter :: Vec2 a -> a+		getter (Vec2 x y) = sqrt (x*x + y*y)+		setter :: a -> Vec2 a -> Vec2 a+		setter r1 v@(Vec2 x y)+			| x == 0.0 && y == 0.0    = Vec2 0.0 0.0+			| r0 == 0.0               = Vec2 0.0 0.0+			| isNaN s || isInfinite s = Vec2 0.0 0.0+			| otherwise               = Vec2 (s*x) (s*y)+			where+				r0 = getter v+				s  = r1/r0++t2 :: forall a. (RealFloat a) => Lens' (Vec2 a) a+t2 = lens getter (flip setter)+	where+		getter :: Vec2 a -> a+		getter v@(Vec2 x y)+			| (v^.r2) == 0.0            = 0.0+			| isNaN v' || isInfinite v' = 0.0+			| otherwise                 = v'+			where+				v' = atan2 y x+		setter :: a -> Vec2 a -> Vec2 a+		setter t1 v@(Vec2 _x _y) =+			Vec2 (r*(cos t1)) (r*(sin t1))+			where+				r = v^.r2++d2 :: (Num a) => Vec2 a -> Vec2 a -> a+d2 (Vec2 ax ay) (Vec2 bx by) = ax*bx + ay*by++-- | Component-wise binary operation.+co2 :: (a -> a -> a) -> Vec2 a -> Vec2 a -> Vec2 a+co2 (+*) (Vec2 ax ay) (Vec2 bx by) = Vec2 (ax +* bx) (ay +* by)++-- | Component-wise foldr.+fr2 :: (a -> acc -> acc) -> acc -> Vec2 a -> acc+fr2 f z (Vec2 x y) = foldr f z [x, y]++-- | Component-wise multiplication.+cm2 :: (Num a) => Vec2 a -> Vec2 a -> Vec2 a+cm2 = co2 (*)++data Vec3 a = Vec3 {+	_x3 :: a,+	_y3 :: a,+	_z3 :: a+}+	deriving (Eq, Ord, Show)+makeLenses ''Vec3++instance Functor Vec3 where+	fmap :: (a -> b) -> (Vec3 a -> Vec3 b)+	fmap f (Vec3 x y z) = Vec3 (f x) (f y) (f z)++instance Field1 (Vec3 a) (Vec3 a) a a where _1 = x3+instance Field2 (Vec3 a) (Vec3 a) a a where _2 = y3+instance Field3 (Vec3 a) (Vec3 a) a a where _3 = z3++instance Applicative Vec3 where+	pure :: a -> Vec3 a+	pure = rv3+	(<*>) :: Vec3 (a -> b) -> Vec3 a -> Vec3 b+	(Vec3 fx fy fz) <*> (Vec3 x y z) = Vec3 (fx x) (fy y) (fz z)++-- | Component-wise multiplication and abs instance.+instance (Num a) => Num (Vec3 a) where+	(+) = pv3+	(-) = minusv3+	fromInteger = rv3 . fromInteger+	abs = fmap abs+	(*) = cm3+	signum = fmap signum++rv3 :: a -> Vec3 a+rv3 z = Vec3 z z z++pv3 :: (Num a) => Vec3 a -> Vec3 a -> Vec3 a+pv3 (Vec3 ax ay az) (Vec3 bx by bz) = Vec3 (ax + bx) (ay + by) (az + bz)++sv3 :: (Num a) => a -> Vec3 a -> Vec3 a+sv3 s (Vec3 x y z) = Vec3 (s*x) (s*y) (s*z)++minusv3 :: (Num a) => Vec3 a -> Vec3 a -> Vec3 a+minusv3 (Vec3 ax ay az) (Vec3 bx by bz) = Vec3 (ax - bx) (ay - by) (az - bz)++d3 :: (Num a) => Vec3 a -> Vec3 a -> a+d3 (Vec3 ax ay az) (Vec3 bx by bz) = ax*bx + ay*by + az*bz++-- | Component-wise binary operation.+co3 :: (a -> a -> a) -> Vec3 a -> Vec3 a -> Vec3 a+co3 (+*) (Vec3 ax ay az) (Vec3 bx by bz) = Vec3 (ax +* bx) (ay +* by) (az +* bz)++-- | Component-wise foldr.+fr3 :: (a -> acc -> acc) -> acc -> Vec3 a -> acc+fr3 f z0 (Vec3 x y z) = foldr f z0 [x, y, z]++-- | Component-wise multiplication.+cm3 :: (Num a) => Vec3 a -> Vec3 a -> Vec3 a+cm3 = co3 (*)++-- | Magnitude of a vector.+r3 :: forall a. (RealFloat a) => Lens' (Vec3 a) a+r3 = lens getter (flip setter)+	where+		getter :: Vec3 a -> a+		getter (Vec3 x y z) = sqrt (x*x + y*y + z*z)+		setter :: a -> Vec3 a -> Vec3 a+		setter r1 v@(Vec3 x y z)+			| (x, y, z) == (0.0, 0.0, 0.0) = Vec3 0.0 0.0 0.0+			| r0 == 0.0                    = Vec3 0.0 0.0 0.0+			| isNaN s || isInfinite s      = Vec3 0.0 0.0 0.0+			| otherwise                    = Vec3 (s*x) (s*y) (s*z)+			where+				r0 = getter v+				s  = r1/r0++data Vec4 a = Vec4 {+	_x4 :: a,+	_y4 :: a,+	_z4 :: a,+	_w4 :: a+}+	deriving (Eq, Ord, Show)+makeLenses ''Vec4++instance Functor Vec4 where+	fmap :: (a -> b) -> (Vec4 a -> Vec4 b)+	fmap f (Vec4 x y z w) = Vec4 (f x) (f y) (f z) (f w)++instance Field1 (Vec4 a) (Vec4 a) a a where _1 = x4+instance Field2 (Vec4 a) (Vec4 a) a a where _2 = y4+instance Field3 (Vec4 a) (Vec4 a) a a where _3 = z4+instance Field4 (Vec4 a) (Vec4 a) a a where _4 = w4++instance Applicative Vec4 where+	pure :: a -> Vec4 a+	pure = rv4+	(<*>) :: Vec4 (a -> b) -> Vec4 a -> Vec4 b+	(Vec4 fx fy fz fw) <*> (Vec4 x y z w) = Vec4 (fx x) (fy y) (fz z) (fw w)++-- | Component-wise multiplication and abs instance.+instance (Num a) => Num (Vec4 a) where+	(+) = pv4+	(-) = minusv4+	fromInteger = rv4 . fromInteger+	abs = fmap abs+	(*) = cm4+	signum = fmap signum++rv4 :: a -> Vec4 a+rv4 z = Vec4 z z z z++pv4 :: (Num a) => Vec4 a -> Vec4 a -> Vec4 a+pv4 (Vec4 ax ay az aw) (Vec4 bx by bz bw) = Vec4 (ax + bx) (ay + by) (az + bz) (aw + bw)++sv4 :: (Num a) => a -> Vec4 a -> Vec4 a+sv4 s (Vec4 x y z w) = Vec4 (s*x) (s*y) (s*z) (s*w)++minusv4 :: (Num a) => Vec4 a -> Vec4 a -> Vec4 a+minusv4 (Vec4 ax ay az aw) (Vec4 bx by bz bw) = Vec4 (ax - bx) (ay - by) (az - bz) (aw - bw)++d4 :: (Num a) => Vec4 a -> Vec4 a -> a+d4 (Vec4 ax ay az aw) (Vec4 bx by bz bw) = ax*bx + ay*by + az*bz + aw*bw++-- | Component-wise binary operation.+co4 :: (a -> a -> a) -> Vec4 a -> Vec4 a -> Vec4 a+co4 (+*) (Vec4 ax ay az aw) (Vec4 bx by bz bw) = Vec4 (ax +* bx) (ay +* by) (az +* bz) (aw +* bw)++-- | Component-wise foldr.+fr4 :: (a -> acc -> acc) -> acc -> Vec4 a -> acc+fr4 f z0 (Vec4 x y z w) = foldr f z0 [x, y, z, w]++-- | Component-wise multiplication.+cm4 :: (Num a) => Vec4 a -> Vec4 a -> Vec4 a+cm4 = co4 (*)++-- | Magnitude of a vector.+r4 :: forall a. (RealFloat a) => Lens' (Vec4 a) a+r4 = lens getter (flip setter)+	where+		getter :: Vec4 a -> a+		getter (Vec4 x y z w) = sqrt (x*x + y*y + z*z + w*w)+		setter :: a -> Vec4 a -> Vec4 a+		setter r1 v@(Vec4 x y z w)+			| (x, y, z, w) == (0.0, 0.0, 0.0, 0.0) = Vec4 0.0 0.0 0.0 0.0+			| r0 == 0.0                            = Vec4 0.0 0.0 0.0 0.0+			| isNaN s || isInfinite s              = Vec4 0.0 0.0 0.0 0.0+			| otherwise                            = Vec4 (s*x) (s*y) (s*z) (s*w)+			where+				r0 = getter v+				s  = r1/r0++-- | Row-major, like C.+newtype Mat3 a = Mat3 { _getMat3 :: Vec3 (Vec3 a) }+	deriving (Eq, Ord, Show)+makeLenses ''Mat3+-- | Row-major, like C.+newtype Mat4 a = Mat4 { _getMat4 :: Vec4 (Vec4 a) }+	deriving (Eq, Ord, Show)+makeLenses ''Mat4++instance Functor Mat3 where+	fmap :: (a -> b) -> (Mat3 a -> Mat3 b)+	fmap f (Mat3 (Vec3 r1_ r2_ r3_)) = Mat3 (Vec3 (f <$> r1_) (f <$> r2_) (f <$> r3_))+instance Functor Mat4 where+	fmap :: (a -> b) -> (Mat4 a -> Mat4 b)+	fmap f (Mat4 (Vec4 r1_ r2_ r3_ r4_)) = Mat4 (Vec4 (f <$> r1_) (f <$> r2_) (f <$> r3_) (f <$> r4_))++instance Field1 (Mat3 a) (Mat3 a) (Vec3 a) (Vec3 a) where _1 = r0_3+instance Field2 (Mat3 a) (Mat3 a) (Vec3 a) (Vec3 a) where _2 = r1_3+instance Field3 (Mat3 a) (Mat3 a) (Vec3 a) (Vec3 a) where _3 = r2_3++instance Field1 (Mat4 a) (Mat4 a) (Vec4 a) (Vec4 a) where _1 = r0_4+instance Field2 (Mat4 a) (Mat4 a) (Vec4 a) (Vec4 a) where _2 = r1_4+instance Field3 (Mat4 a) (Mat4 a) (Vec4 a) (Vec4 a) where _3 = r2_4+instance Field4 (Mat4 a) (Mat4 a) (Vec4 a) (Vec4 a) where _4 = r3_4++instance Applicative Mat3 where+	pure :: a -> Mat3 a+	pure z = let reps = rv3 z in Mat3 $ rv3 reps+	(<*>) :: Mat3 (a -> b) -> Mat3 a -> Mat3 b+	(Mat3 frows) <*> (Mat3 rows) = Mat3 $ ((<*>) <$> frows) <*> rows+instance Applicative Mat4 where+	pure :: a -> Mat4 a+	pure z = let reps = rv4 z in Mat4 $ rv4 reps+	(<*>) :: Mat4 (a -> b) -> Mat4 a -> Mat4 b+	(Mat4 frows) <*> (Mat4 rows) = Mat4 $ ((<*>) <$> frows) <*> rows++r0_3 :: Lens' (Mat3 a) (Vec3 a)+r0_3 = getMat3.x3++r1_3 :: Lens' (Mat3 a) (Vec3 a)+r1_3 = getMat3.y3++r2_3 :: Lens' (Mat3 a) (Vec3 a)+r2_3 = getMat3.z3++r0_4 :: Lens' (Mat4 a) (Vec4 a)+r0_4 = getMat4.x4++r1_4 :: Lens' (Mat4 a) (Vec4 a)+r1_4 = getMat4.y4++r2_4 :: Lens' (Mat4 a) (Vec4 a)+r2_4 = getMat4.z4++r3_4 :: Lens' (Mat4 a) (Vec4 a)+r3_4 = getMat4.w4++e0_0_4 :: Lens' (Mat4 a) a+e0_0_4 = r0_4.x4+e0_1_4 :: Lens' (Mat4 a) a+e0_1_4 = r0_4.y4+e0_2_4 :: Lens' (Mat4 a) a+e0_2_4 = r0_4.z4+e0_3_4 :: Lens' (Mat4 a) a+e0_3_4 = r0_4.w4++e1_0_4 :: Lens' (Mat4 a) a+e1_0_4 = r1_4.x4+e1_1_4 :: Lens' (Mat4 a) a+e1_1_4 = r1_4.y4+e1_2_4 :: Lens' (Mat4 a) a+e1_2_4 = r1_4.z4+e1_3_4 :: Lens' (Mat4 a) a+e1_3_4 = r1_4.w4++e2_0_4 :: Lens' (Mat4 a) a+e2_0_4 = r2_4.x4+e2_1_4 :: Lens' (Mat4 a) a+e2_1_4 = r2_4.y4+e2_2_4 :: Lens' (Mat4 a) a+e2_2_4 = r2_4.z4+e2_3_4 :: Lens' (Mat4 a) a+e2_3_4 = r2_4.w4++e3_0_4 :: Lens' (Mat4 a) a+e3_0_4 = r3_4.x4+e3_1_4 :: Lens' (Mat4 a) a+e3_1_4 = r3_4.y4+e3_2_4 :: Lens' (Mat4 a) a+e3_2_4 = r3_4.z4+e3_3_4 :: Lens' (Mat4 a) a+e3_3_4 = r3_4.w4++e0_0_3 :: Lens' (Mat3 a) a+e0_0_3 = r0_3.x3+e0_1_3 :: Lens' (Mat3 a) a+e0_1_3 = r0_3.y3+e0_2_3 :: Lens' (Mat3 a) a+e0_2_3 = r0_3.z3++e1_0_3 :: Lens' (Mat3 a) a+e1_0_3 = r1_3.x3+e1_1_3 :: Lens' (Mat3 a) a+e1_1_3 = r1_3.y3+e1_2_3 :: Lens' (Mat3 a) a+e1_2_3 = r1_3.z3++e2_0_3 :: Lens' (Mat3 a) a+e2_0_3 = r2_3.x3+e2_1_3 :: Lens' (Mat3 a) a+e2_1_3 = r2_3.y3+e2_2_3 :: Lens' (Mat3 a) a+e2_2_3 = r2_3.z3++transposeMat3 :: Mat3 a -> Mat3 a+transposeMat3 (Mat3 (Vec3+		(Vec3 v0_0 v0_1 v0_2)+		(Vec3 v1_0 v1_1 v1_2)+		(Vec3 v2_0 v2_1 v2_2)+	)) = Mat3 (Vec3+		(Vec3 v0_0 v1_0 v2_0)+		(Vec3 v0_1 v1_1 v2_1)+		(Vec3 v0_2 v1_2 v2_2)+	)++transposeMat4 :: Mat4 a -> Mat4 a+transposeMat4 (Mat4 (Vec4+		(Vec4 v0_0 v0_1 v0_2 v0_3)+		(Vec4 v1_0 v1_1 v1_2 v1_3)+		(Vec4 v2_0 v2_1 v2_2 v2_3)+		(Vec4 v3_0 v3_1 v3_2 v3_3)+	)) = Mat4 (Vec4+		(Vec4 v0_0 v1_0 v2_0 v3_0)+		(Vec4 v0_1 v1_1 v2_1 v3_1)+		(Vec4 v0_2 v1_2 v2_2 v3_2)+		(Vec4 v0_3 v1_3 v2_3 v3_3)+	)++c0_3 :: Lens' (Mat3 a) (Vec3 a)+c0_3 = transposeM3.r0_3++c1_3 :: Lens' (Mat3 a) (Vec3 a)+c1_3 = transposeM3.r1_3++c2_3 :: Lens' (Mat3 a) (Vec3 a)+c2_3 = transposeM3.r2_3++c0_4 :: Lens' (Mat4 a) (Vec4 a)+c0_4 = transposeM4.r0_4++c1_4 :: Lens' (Mat4 a) (Vec4 a)+c1_4 = transposeM4.r1_4++c2_4 :: Lens' (Mat4 a) (Vec4 a)+c2_4 = transposeM4.r2_4++c3_4 :: Lens' (Mat4 a) (Vec4 a)+c3_4 = transposeM4.r3_4++transposeM3 :: Lens' (Mat3 a) (Mat3 a)+transposeM3 = lens getter (flip setter)+	where+		getter :: Mat3 a -> Mat3 a+		getter m = transposeMat3 m+		setter :: Mat3 a -> Mat3 a -> Mat3 a+		setter m _ = transposeMat3 m++transposeM4 :: Lens' (Mat4 a) (Mat4 a)+transposeM4 = lens getter (flip setter)+	where+		getter :: Mat4 a -> Mat4 a+		getter m = transposeMat4 m+		setter :: Mat4 a -> Mat4 a -> Mat4 a+		setter m _ = transposeMat4 m++-- | Matrix multiplication.+--+-- This is not commutative.+mm3 :: (Num a) => Mat3 a -> Mat3 a -> Mat3 a+mm3 a b = (Mat3 (Vec3+		(Vec3 (d3 (a^.r0_3) (b^.c0_3))  (d3 (a^.r0_3) (b^.c1_3))  (d3 (a^.r0_3) (b^.c2_3)))+		(Vec3 (d3 (a^.r1_3) (b^.c0_3))  (d3 (a^.r1_3) (b^.c1_3))  (d3 (a^.r1_3) (b^.c2_3)))+		(Vec3 (d3 (a^.r2_3) (b^.c0_3))  (d3 (a^.r2_3) (b^.c1_3))  (d3 (a^.r2_3) (b^.c2_3)))+	))++-- | Matrix multiplication.+--+-- This is not commutative.+mm4 :: (Num a) => Mat4 a -> Mat4 a -> Mat4 a+mm4 a b = (Mat4 (Vec4+		(Vec4 (d4 (a^.r0_4) (b^.c0_4))  (d4 (a^.r0_4) (b^.c1_4))  (d4 (a^.r0_4) (b^.c2_4))  (d4 (a^.r0_4) (b^.c3_4)))+		(Vec4 (d4 (a^.r1_4) (b^.c0_4))  (d4 (a^.r1_4) (b^.c1_4))  (d4 (a^.r1_4) (b^.c2_4))  (d4 (a^.r1_4) (b^.c3_4)))+		(Vec4 (d4 (a^.r2_4) (b^.c0_4))  (d4 (a^.r2_4) (b^.c1_4))  (d4 (a^.r2_4) (b^.c2_4))  (d4 (a^.r2_4) (b^.c3_4)))+		(Vec4 (d4 (a^.r3_4) (b^.c0_4))  (d4 (a^.r3_4) (b^.c1_4))  (d4 (a^.r3_4) (b^.c2_4))  (d4 (a^.r3_4) (b^.c3_4)))+	))++v3magnitude :: (Num a, Floating a) => Vec3 a -> a+v3magnitude (Vec3 x y z) = sqrt $ x*x + y*y + z*z++v3normalize :: (Num a, Floating a) => Vec3 a -> Vec3 a+v3normalize v = (1/v3magnitude v) `sv3` v++v4magnitude :: (Num a, Floating a) => Vec4 a -> a+v4magnitude (Vec4 x y z w) = sqrt $ x*x + y*y + z*z + w*w++v4normalize :: (Num a, Floating a) => Vec4 a -> Vec4 a+v4normalize v = (1/v4magnitude v) `sv4` v++identity3 :: (Num a, Fractional a) => Mat3 a+identity3 = Mat3 $ Vec3+	(Vec3 1.0 0.0 0.0)+	(Vec3 0.0 1.0 0.0)+	(Vec3 0.0 0.0 1.0)++identity4 :: (Num a, Fractional a) => Mat4 a+identity4 = Mat4 $ Vec4+	(Vec4 1.0 0.0 0.0 0.0)+	(Vec4 0.0 1.0 0.0 0.0)+	(Vec4 0.0 0.0 1.0 0.0)+	(Vec4 0.0 0.0 0.0 1.0)++instance (Num a, Fractional a) => Semigroup (Mat3 a) where+	(<>) = mm3+instance (Num a, Fractional a) => Semigroup (Mat4 a) where+	(<>) = mm4+instance (Num a, Fractional a) => Monoid (Mat3 a) where+	mempty = identity3+instance (Num a, Fractional a) => Monoid (Mat4 a) where+	mempty = identity4++data Rect a = Rect {+	_rectp1 :: Vec2 a,+	_rectp2 :: Vec2 a+}+	deriving (Eq, Ord, Show)+makeLenses ''Rect++-- | Not a lens by laws definition; see 'rectBottom'.+rectLowerLeft :: forall a. (Ord a) => Lens' (Rect a) (Vec2 a)+rectLowerLeft = lens getter (flip setter)+	where+		getter :: Rect a -> Vec2 a+		getter (Rect (Vec2 ax ay) (Vec2 bx by)) = Vec2 (if' (ax <= bx) ax bx) (if' (ay <= by) ay by)+		setter :: Vec2 a -> Rect a -> Rect a+		setter (Vec2 x' y') (Rect (Vec2 ax ay) (Vec2 bx by)) = Rect (Vec2 (if' (ax <= bx) x' ax) (if' (ay <= by) y' ay)) (Vec2 (if' (ax <= bx) bx x') (if' (ay <= by) by y'))++-- | Not a lens by laws definition; see 'rectBottom'.+rectUpperRight :: forall a. (Ord a) => Lens' (Rect a) (Vec2 a)+rectUpperRight = lens getter (flip setter)+	where+		getter :: Rect a -> Vec2 a+		getter (Rect (Vec2 ax ay) (Vec2 bx by)) = Vec2 (if' (ax <= bx) bx ax) (if' (ay <= by) by ay)+		setter :: Vec2 a -> Rect a -> Rect a+		setter (Vec2 x' y') (Rect (Vec2 ax ay) (Vec2 bx by)) = Rect (Vec2 (if' (ax <= bx) ax x') (if' (ay <= by) ay y')) (Vec2 (if' (ax <= bx) x' bx) (if' (ay <= by) y' by))++-- | Not a lens by laws definition; see 'rectBottom'.+rectCenter :: forall a. (Num a, Fractional a) => Lens' (Rect a) (Vec2 a)+rectCenter = lens getter (flip setter)+	where+		getter :: Rect a -> Vec2 a+		getter (Rect p1 p2) = lerpV2 p1 p2 0.5+		setter :: (Vec2 a) -> Rect a -> Rect a+		setter c1 r@(Rect p1 p2) = Rect (p1 `pv2` offset) (p2 `pv2` offset)+			where+				offset = c1 `minusv2` c0+				c0 = getter r++-- | Not a lens by laws definition; see 'rectBottom'.+rectTop :: forall a. (Ord a) => Lens' (Rect a) a+rectTop = lens getter (flip setter)+	where+		getter :: Rect a -> a+		getter (Rect (Vec2 _ax ay) (Vec2 _bx by)) = if' (ay <= by) by ay+		setter :: a -> Rect a -> Rect a+		setter y' (Rect (Vec2 ax ay) (Vec2 bx by)) = Rect (Vec2 ax (if' (ay <= by) ay y')) (Vec2 bx (if' (ay <= by) y' by))++-- | Not a lens by laws definition; see 'rectBottom'.+rectRight :: forall a. (Ord a) => Lens' (Rect a) a+rectRight = lens getter (flip setter)+	where+		getter :: Rect a -> a+		getter (Rect (Vec2 ax _ay) (Vec2 bx _by)) = if' (ax <= bx) bx ax+		setter :: a -> Rect a -> Rect a+		setter x' (Rect (Vec2 ax ay) (Vec2 bx by)) = Rect (Vec2 (if' (ax <= bx) ax x') ay) (Vec2 (if' (ax <= bx) x' bx) by)++-- | This lens does not satisfy the 1st lens law, since you can set a new+-- bottom above the old top.  Same for the other 3 setters in this category, and also the corner setters.+rectBottom :: forall a. (Ord a) => Lens' (Rect a) a+rectBottom = lens getter (flip setter)+	where+		getter :: Rect a -> a+		getter (Rect (Vec2 _ax ay) (Vec2 _bx by)) = if' (ay <= by) ay by+		setter :: a -> Rect a -> Rect a+		setter y' (Rect (Vec2 ax ay) (Vec2 bx by)) = Rect (Vec2 ax (if' (ay <= by) y' ay)) (Vec2 bx (if' (ay <= by) by y'))++-- | Not a lens by laws definition; see 'rectBottom'.+rectLeft :: forall a. (Ord a) => Lens' (Rect a) a+rectLeft = lens getter (flip setter)+	where+		getter :: Rect a -> a+		getter (Rect (Vec2 ax _ay) (Vec2 bx _by)) = if' (ax <= bx) ax bx+		setter :: a -> Rect a -> Rect a+		setter x' (Rect (Vec2 ax ay) (Vec2 bx by)) = Rect (Vec2 (if' (ax <= bx) x' ax) ay) (Vec2 (if' (ax <= bx) bx x') by)++-- | Not a lens by laws definition; see 'rectBottom'.+rectUpperLeft :: forall a. (Ord a) => Lens' (Rect a) (Vec2 a)+rectUpperLeft = lens getter (flip setter)+	where+		getter :: Rect a -> Vec2 a+		getter (Rect (Vec2 ax ay) (Vec2 bx by)) = Vec2 (if' (ax <= bx) ax bx) (if' (ay <= by) by ay)+		setter :: Vec2 a -> Rect a -> Rect a+		setter (Vec2 x' y') (Rect (Vec2 ax ay) (Vec2 bx by)) = Rect (Vec2 (if' (ax <= bx) x' ax) (if' (ay <= by) ay y')) (Vec2 (if' (ax <= bx) bx x') (if' (ay <= by) y' by))++-- | Not a lens by laws definition; see 'rectBottom'.+rectLowerRight :: forall a. (Ord a) => Lens' (Rect a) (Vec2 a)+rectLowerRight = lens getter (flip setter)+	where+		getter :: Rect a -> Vec2 a+		getter (Rect (Vec2 ax ay) (Vec2 bx by)) = Vec2 (if' (ax <= bx) bx ax) (if' (ay <= by) ay by)+		setter :: Vec2 a -> Rect a -> Rect a+		setter (Vec2 x' y') (Rect (Vec2 ax ay) (Vec2 bx by)) = Rect (Vec2 (if' (ax <= bx) ax x') (if' (ay <= by) y' ay)) (Vec2 (if' (ax <= bx) x' bx) (if' (ay <= by) by y'))++rectWidthAboutCenter :: forall a. (Num a, Fractional a) => Lens' (Rect a) a+rectWidthAboutCenter = lens getter (flip setter)+	where+		getter :: Rect a -> a+		getter (Rect (Vec2 ax _ay) (Vec2 bx _by)) = abs $ bx - ax+		setter :: a -> Rect a -> Rect a+		setter w1 (Rect (Vec2 ax ay) (Vec2 bx by)) = Rect (Vec2 (cx - wr) ay) (Vec2 (cx + wr) by)+			where+				cx = ax + (bx - ax)/2+				wr = w1/2++rectHeightAboutCenter :: forall a. (Num a, Fractional a) => Lens' (Rect a) a+rectHeightAboutCenter = lens getter (flip setter)+	where+		getter :: Rect a -> a+		getter (Rect (Vec2 _ax ay) (Vec2 _bx by)) = abs $ by - ay+		setter :: a -> Rect a -> Rect a+		setter h1 (Rect (Vec2 ax ay) (Vec2 bx by)) = Rect (Vec2 ax (cy - hr)) (Vec2 bx (cy + hr))+			where+				cy = ay + (by - ay)/2+				hr = h1/2++-- | Proportion preserving scaling.+rectAvgSideAboutCenter :: forall a. (Num a, Fractional a, RealFloat a) => Lens' (Rect a) a+rectAvgSideAboutCenter = lens getter (flip setter)+	where+		getter :: Rect a -> a+		getter r = lerp (r^.rectWidthAboutCenter) (r^.rectHeightAboutCenter) 0.5+		setter :: a -> Rect a -> Rect a+		setter avgSide r+			| isNaN s || isInfinite s = Rect z z+			| otherwise               = r & rectWidthAboutCenter %~ (s*) & rectHeightAboutCenter %~ (s*)+			where+				s = avgSide / getter r+				z = Vec2 (realToFrac (0.0 :: Double)) (realToFrac (0.0 :: Double))++rectNormalize :: (Ord a) => Rect a -> Rect a+rectNormalize r = Rect (r^.rectLowerLeft) (r^.rectUpperRight)++isInRect :: (Ord a) => Rect a -> Vec2 a -> Bool+isInRect = isInRect' False++isInRect' :: (Ord a) => Bool -> Rect a -> Vec2 a -> Bool+isInRect' exclusive r (Vec2 px py) = ll^.x2 <=- px && px <=- ur^.x2  &&  ll^.y2 <=- py && py <=- ur^.y2+	where+		ll = r^.rectLowerLeft+		ur = r^.rectUpperRight+		infixl 4 <=-+		(<=-) = if' (not exclusive) (<=) (<)++lerpWith :: (a -> a -> a) -> (a -> a -> a) -> (s -> a -> a) -> a -> a -> s -> a+lerpWith plus minus scale from_ to_ v = from_ `plus` (v`scale`(to_ `minus` from_))++lerp :: (Num a) => a -> a -> a -> a+--lerp from to v = from + v*(to - from)+lerp = lerpWith (+) (-) (*)++lerpV2 :: (Num a) => Vec2 a -> Vec2 a -> a -> Vec2 a+lerpV2 = lerpWith pv2 minusv2 sv2++lerpV3 :: (Num a) => Vec3 a -> Vec3 a -> a -> Vec3 a+lerpV3 = lerpWith pv3 minusv3 sv3++lerpV4 :: (Num a) => Vec4 a -> Vec4 a -> a -> Vec4 a+lerpV4 = lerpWith pv4 minusv4 sv4++ilerpWith :: (a -> s) -> (a -> a -> a) -> (s -> s -> s) -> a -> a -> a -> s+--ilerpWith from_ to_ on_ = (on_ - from_) / (to_ - from_)+ilerpWith flatten minus div_ from_ to_ on_ = (flatten $ on_ `minus` from_) `div_` (flatten $ to_ `minus` from_)++-- | Inverse lerp on x3.+--+-- Get the lerp3 that would provide input x3.  Find how close input x3 is to+-- destination x2 relative to source x1.+ilerp :: (Num a, Fractional a) => a -> a -> a -> a+ilerp = ilerpWith id (-) (/)++-- | pi is in prelude and yet tau isn't.+tau :: (Floating a) => a+tau = 2*pi++type WidthHeightI = (Integer, Integer)++-- | Homonogenous coordinates.+v4to3 :: (Fractional a) => Vec4 a -> Vec3 a+v4to3 (Vec4 x y z w) = Vec3 (x/w) (y/w) (z/w)++v3to4 :: (Fractional a) => Vec3 a -> Vec4 a+v3to4 (Vec3 x y z) = Vec4 x y z 1.0++-- | Apply a transformation matrix to a vector.+--+-- The vector is interpreted as a 4x1 matrix, like a column.+--+-- You can think of multiplication of a matrix with a vector like this:+--+--          x+--          x+--          x+--          x+--+-- x x x x  ?+-- x x x x  ?+-- x x x x  ?+-- x x x x  ?+--+-- In the middle is the result of ? we want to find.  Above it is the vector.+-- To the left of the result is the matrix.  This visual may aid in+-- understanding this basic linear algebra.  I like to think of the column on+-- top as like a falling block, with its top falling to the left, so that it+-- rotates 45 degrees counter-clockwise.  It first falls onto the top row, and+-- you take the dot product to get the first ‘?’ result.  Repeat for the second+-- ‘?’ on the second row and so on.  Note that if you had 4 vectors (columns)+-- above, you could do the same, taking that column as a brick-like block, and+-- letting it fall onto a row of the matrix of the left, and then you'd get+-- full matrix-matrix multiplication.+--+-- Each row of the transformation matrix tells you how to get a new coordinate,+-- i.e. what the result is of mapping a coordinate after the transformation back+-- into original coordinates.  The first row is like a weighted sum, taking+-- each input coordinate, and producing an ‘x’ coordinate.  The second row+-- likewise, producing a ‘y’ coordinate.  (e.g. for ‘y’ coordinate, a row of ‘0 1 0 0’+-- simply returns the ‘y’ coordinate unchanged, and ‘0.5 0.5 0.0 0.0’ would+-- provide the value half-way between the input x and y coordinates as the new y+-- coordinate.+--+-- The columns of the transformation matrix can be interpreted to mean the new+-- axes after your transformation.  e.g. if you scale the z axis by 2, making+-- it double in size, the new z axis is represented by the vector from the+-- origin to the point ‘0 0 2 0’.  This can also be useful for 3D rotation,+-- since it can be easier to do rotations in a simple, 2D plane, dealing with+-- just some sines, cosines, and angles.+--+-- We usually use the transformation on the matrix and the vector on the right.+-- You can do it in reverse order, but then the matrix would need to be+-- transposed, and the vector would be a row rather than a column.  For the+-- reversed order, see 'vm4'.+--+-- Finally, we usually use 4D vectors to deal with 3D space through what's+-- called homogonous coordinates, an extra coordinate, which lets us more+-- easily represent translations and perspectives.  The meaning of the last+-- coordinate with homogonous coordinates is that all the other coordinates are+-- divided by it.  Often the 4th coordinate can just be ‘1’.  This gives the+-- property that multiplying a scalar by the vector yields an equivalent point.+-- It also happens to be convenient for translations and perspectives.+mv4 :: (Num a) => Mat4 a -> Vec4 a -> Vec4 a+mv4 m v = Vec4 (d4 (m^.r0_4) v) (d4 (m^.r1_4) v) (d4 (m^.r2_4) v) (d4 (m^.r3_4) v)++-- | See 'mv4'; this is just for 3d vectors.+--+-- mv4 is 4d but we use 4d vectors to represent 3d vectors in order to more+-- easily represent translations and perspectives, through what's known as+-- homogonous coordinates, where the components except the last is divided by+-- the last component, and where a vector can be multiplied by a scalar and+-- getting an equivalent vector.+mv3 :: (Num a) => Mat3 a -> Vec3 a -> Vec3 a+mv3 m v = Vec3 (d3 (m^.r0_3) v) (d3 (m^.r1_3) v) (d3 (m^.r2_3) v)++m4v3 :: (Num a, Fractional a) => Mat4 a -> Vec3 a -> Vec3 a+m4v3 m v = v4to3 . mv4 m . v3to4 $ v++-- | (The vector is interpreted as a 1x4 matrix.)+--+-- Note the vector is on the left with a transposed matrix.  We personally use+-- vector on the right with mv3, where the columns, not the rows, are the new+-- axes, and points in terms of the new axes are mapped back to the original+-- coordinates with the transformation matrix.)+vm3 :: (Num a) => Vec3 a -> Mat3 a -> Vec3 a+vm3 v m = Vec3 (d3 v (m^.c0_3)) (d3 v (m^.c1_3)) (d3 v (m^.c2_3))++-- | Vector on the left with transposed transformation matrix.+--+-- See also 'vm3' and 'v4m'.+vm4 :: (Num a) => Vec4 a -> Mat4 a -> Vec4 a+vm4 v m = Vec4 (d4 v (m^.c0_4)) (d4 v (m^.c1_4)) (d4 v (m^.c2_4)) (d4 v (m^.c3_4))++v3m4 :: (Num a, Fractional a) => Vec3 a -> Mat4 a -> Vec3 a+v3m4 v m = v4to3 $ vm4 (v3to4 v) m++v2or :: (RealFloat a) => Vec2 a -> Vec2 a+v2or = v2orWith (Vec2 0.0 0.0)++v2orWith :: (RealFloat a) => Vec2 a -> Vec2 a -> Vec2 a+v2orWith else_ v@(Vec2 x y)+	| isNaN x || isInfinite x = else_+	| isNaN y || isInfinite y = else_+	| otherwise = v++v3or :: (RealFloat a) => Vec3 a -> Vec3 a+v3or = v3orWith (Vec3 0.0 0.0 0.0)++v3orWith :: (RealFloat a) => Vec3 a -> Vec3 a -> Vec3 a+v3orWith else_ v@(Vec3 x y z)+	| isNaN x || isInfinite x = else_+	| isNaN y || isInfinite y = else_+	| isNaN z || isInfinite z = else_+	| otherwise = v++-- | Cross product.+--+-- Satisfies a x b = |a| * |b| * sin(t) * n, providing a vector perpendicular+-- to the plane containing both vectors (if linearly independent) with a magnitude+-- equal to the product of magnitudes at the sin of the angle between them.+vx3 :: (Num a) => Vec3 a -> Vec3 a -> Vec3 a+vx3 (Vec3 ax ay az) (Vec3 bx by bz) = Vec3 (ay*bz - az*by) (az*bx - ax*bz) (ax*by - ay*bx)++-- | Find a vector perpendicular.+v2perp :: (Num a) => Vec2 a -> Vec2 a+v2perp (Vec2 x y) = Vec2 (-y) x++-- | Find a vector perpendicular to the normal, with v2perp on the largest+-- magnitude component (which is non-zero iff the vector is non-zero) and some+-- other component (the next one).+v3perp :: (Num a, Ord a) => Vec3 a -> Vec3 a+v3perp (Vec3 x y z)+	| abs y <= abs x && abs z <= abs x = Vec3 (-y) x    z+	| abs z <= abs y && abs x <= abs y = Vec3 x    (-z) y+	| otherwise                        = Vec3 z    y    (-x)++-- | A representation of a simple 3D rotation about an axis that intersects the+-- origin.+data SimpleRotation a = SimpleRotation {+	_srCcwAngle   :: a,+	_srOriginAxis :: Vec3 a+}+	deriving (Eq, Ord, Show)+makeLenses ''SimpleRotation++-- | A complex number with 3 imaginary components instead of 1.+--+-- It is sometimes used to represent 3D rotations as an alternative to transformation matrices.+--+-- ij = -ji = k; jk = -kj = i; ki = -ik = j; i^2 = j^2 = k^2 = -1.+--+-- Beyond this I haven't learned much about these things.+data Quaternion a = Quaternion {+	_qReal   :: a,+	_qVector :: Vec3 a+}+	deriving (Eq, Ord, Show)+makeLenses ''Quaternion++qasv4 :: Lens' (Quaternion a) (Vec4 a)+qasv4 = lens getter (flip setter)+	where+		getter :: Quaternion a -> Vec4 a+		getter (Quaternion a (Vec3 b c d)) = Vec4 a b c d+		setter :: Vec4 a -> Quaternion a -> Quaternion a+		setter (Vec4 a b c d) _ = Quaternion a (Vec3 b c d)++-- | Scale quaternion.+sq :: (Num a) => a -> Quaternion a -> Quaternion a+sq s (Quaternion a (Vec3 b c d)) = Quaternion (s*a) (Vec3 (s*b) (s*c) (s*d))++-- | Plus quaternion.+pq :: (Num a) => Quaternion a -> Quaternion a -> Quaternion a+pq (Quaternion aa (Vec3 ab ac ad)) (Quaternion ba (Vec3 bb bc bd)) = Quaternion (aa + ba) (Vec3 (ab + bb) (ac + bc) (ad + bd))++-- | Minus quaternion.+mq :: (Num a) => Quaternion a -> Quaternion a -> Quaternion a+mq (Quaternion aa (Vec3 ab ac ad)) (Quaternion ba (Vec3 bb bc bd)) = Quaternion (aa - ba) (Vec3 (ab - bb) (ac - bc) (ad - bd))++-- | quaternion ^ -1.+--+-- (Quaternion multiplicative inverse.)+qmi :: (Num a, Fractional a) => Quaternion a -> Quaternion a+qmi (Quaternion a (Vec3 b c d)) = sq (1/(a*a + b*b + c*c + d*d)) $ Quaternion a (Vec3 (-b) (-c) (-d))++-- | Quaternion multiplication.+--+-- ‘Hamilton product’: distribute bases.+qq :: (Num a) => Quaternion a -> Quaternion a -> Quaternion a+qq (Quaternion aa (Vec3 ab ac ad)) (Quaternion ba (Vec3 bb bc bd)) =+	Quaternion+		(aa*ba - ab*bb - ac*bc - ad*bd) $ Vec3+		(aa*bb + ab*ba + ac*bd - ad*bc)+		(aa*bc - ab*bd + ac*ba + ad*bb)+		(aa*bd + ab*bc - ac*bb + ad*ba)++-- | Convert a vector to a quaternion representation.+--+-- This can be conjugated with a rotation quaternion to rotate a vector.+v3q :: (Fractional a) => Vec3 a -> Quaternion a+v3q v = Quaternion 0.0 v++-- | Conjugate a 3D vector by a quaternion.+--+-- If the quaternion represents a rotation, the vector will be rotated.+qcv3 :: (Num a, Fractional a) => Quaternion a -> Vec3 a -> Vec3 a+qcv3 q v = (^.qVector) $ q `qq` (v3q v) `qq` (qmi q)++-- | Convert a 'SimpleRotation' to a quaternion.+srToQ :: (Num a, Floating a) => SimpleRotation a -> Quaternion a+srToQ sr = Quaternion (cos ((sr^.srCcwAngle)/2)) $ (sin ((sr^.srCcwAngle)/2)) `sv3` (v3normalize $ sr^.srOriginAxis)++qnormalize :: (Num a, Fractional a, Floating a) => Quaternion a -> Quaternion a+qnormalize q = (1/qmagnitude q) `sq` q++qmagnitude :: (Num a, Floating a) => Quaternion a -> a+qmagnitude (Quaternion a (Vec3 b c d)) = sqrt $ a*a + b*b + c*c + d*d++-- | Convert a quaternion-encoded rotation to a SimpleRotation.+--+-- The magnitude of the vector is the sine of half the angle of rotation.+--+-- Get the sign of Real to get the quadrant.+qToSr :: (RealFloat a, Num a) => Quaternion a -> SimpleRotation a+qToSr (Quaternion a v) = SimpleRotation {+	_srCcwAngle   = atan2 (2 * asin (v3magnitude v)) (2 * acos a),+	_srOriginAxis = v3normalize v+}++-- | Encode the angle as the magnitude.+srToVec3 :: (Num a) => SimpleRotation a -> Vec3 a+srToVec3 sr = (sr^.srCcwAngle) `sv3` (sr^.srOriginAxis)++-- | Decode the angle as the magnitude.+v3ToSr :: (Floating a, RealFloat a) => Vec3 a -> SimpleRotation a+v3ToSr v = SimpleRotation {+	_srCcwAngle   = v3magnitude $ v,+	_srOriginAxis = v3or . v3normalize $ v+}++-- | Rotate x radians about the axis pointing in direction, which intersects the origin.+--+-- You can use 'v3to4' and 'v4to3' as needed to translate between homogenous+-- coordinates and non-homogenous coordinates.+simpleRotate :: (Num a, RealFloat a) => SimpleRotation a -> Vec3 a -> Vec3 a+simpleRotate sr v = rotate3Simple sr `mv3` v++m3to4 :: (Fractional a) => Mat3 a -> Mat4 a+m3to4 (Mat3 (Vec3+		(Vec3 v0_0 v0_1 v0_2)+		(Vec3 v1_0 v1_1 v1_2)+		(Vec3 v2_0 v2_1 v2_2)+	)) = Mat4 (Vec4+		(Vec4 v0_0 v0_1 v0_2 0.0)+		(Vec4 v1_0 v1_1 v1_2 0.0)+		(Vec4 v2_0 v2_1 v2_2 0.0)+		(Vec4 0.0  0.0  0.0  1.0)+	)++-- | Make a transformation that applies the given component-wise scale.+scale3 :: (Fractional a) => Vec3 a -> Mat4 a+scale3 = m3to4 . scale3Simple++-- | Make a transformation that applies the given component-wise scale.+scale3Simple :: (Fractional a) => Vec3 a -> Mat3 a+scale3Simple v = Mat3 $ Vec3+	(Vec3 (v^.x3) 0.0     0.0)+	(Vec3 0.0     (v^.y3) 0.0)+	(Vec3 0.0     0.0     (v^.z3))++-- | Make a transformation that applies the given component-wise scale.+scale4 :: (Fractional a) => Vec4 a -> Mat4 a+scale4 v = Mat4 $ Vec4+	(Vec4 (v^.x4) 0.0     0.0     0.0)+	(Vec4 0.0     (v^.y4) 0.0     0.0)+	(Vec4 0.0     0.0     (v^.z4) 0.0)+	(Vec4 0.0     0.0     0.0     (v^.w4))++-- | Make a transformation matrix that translates a 3D point in 4D homogeneous coordinates.+--+-- (Note this in the order we normally use, where you can multiply a vector to+-- the right of the matrix.  You can still transpose the matrix to multiply in the+-- reverse order.)+translate3 :: (Fractional a) => Vec3 a -> Mat4 a+translate3 v = Mat4 $ Vec4+	(Vec4 1.0 0.0 0.0 (v^.x3))+	(Vec4 0.0 1.0 0.0 (v^.y3))+	(Vec4 0.0 0.0 1.0 (v^.z3))+	(Vec4 0.0 0.0 0.0 1.0)++-- | Rotate about an axis in the xy plane so that the new z axis becomes as+-- specified.+--+-- Similarly to 'tilt3ySimple', multiply by ‘i’ to perform a right angle CCW+-- rotation in the corresponding plane with normalization, and for the second+-- rotation, if there is a roll (i.e. rotation in xz), treat the non-y+-- component as a projection of the length of z's xz.+tilt3z :: (Floating a, Num a, Fractional a, RealFloat a, SmallNum a) => Vec3 a -> Mat4 a+tilt3z = m3to4 . tilt3zSimple++-- | 'tilt3z' without homogeneous coordinates.+tilt3zSimple :: (Floating a, Num a, Fractional a, RealFloat a, SmallNum a) => Vec3 a -> Mat3 a+tilt3zSimple z_ = Mat3 $ Vec3+	-- new x axis           new y axis               new z axis+	( Vec3 ( z'^.z3 / zhr') (-(z'^.x3/zhr')*(z^.y3)) (z^.x3) )+	( Vec3 0.0              (zhr                   ) (z^.y3) )+	( Vec3 (-z'^.x3 / zhr') (-(z'^.z3/zhr')*(z^.y3)) (z^.z3) )+	where+		sq_ a = a * a+		z = v3normalize z_+		zhr = Vec2 (z^.x3) (z^.z3) ^. r2+		zhr' = Vec2 (z'^.x3) (z'^.z3) ^. r2  -- = sqrt $ sq_ z^.x3 + sq_ z^.y3  -- normalizes new x axis+		--zh = Vec2 (z'^.x3) (z'^.z3) -- The 2D vector mentioned above.+		--zhr = zh^. r2  -- = sqrt $ sq_ z^.x3 + sq_ z^.z3  -- normalizes new x axis++		-- z': this handles the special case of z==0,±1,0, where the new x axis should be 1,0,0, (and the new z axis should be 0,0,∓1).+		z' | sqrt (sq_ (z^.x3) + sq_ (z^.z3)) <= smallNum = Vec3 0.0 0.0 1.0 | otherwise = z++tilt3zReverse :: (Floating a, Num a, Fractional a, RealFloat a, SmallNum a) => Vec3 a -> Mat4 a+tilt3zReverse = m3to4 . tilt3zReverseSimple++tilt3zReverseSimple :: (Floating a, Num a, Fractional a, RealFloat a, SmallNum a) => Vec3 a -> Mat3 a+tilt3zReverseSimple (Vec3 x y z) = tilt3zSimple $ Vec3 (-x) (-y) z++-- | Rotate horizontally (xy plane around z axis), then rotate vertically by+-- treating x and y as a single number by magnitude and rotating with z.+tilt3y :: (Floating a, Num a, Fractional a, RealFloat a, SmallNum a) => Vec3 a -> Mat4 a+tilt3y = m3to4 . tilt3ySimple++-- | 'tilt3y' without homogeneous coordinates.+--+-- new x axis's z is 0.  Without horizontal tilt, new z axis's x is 0, but then+-- add horizontal rotate.+--+-- The new x axis is the 2D y vector without z rotated right 45 degrees (like+-- multiplying a complex number by i but in reverse), renormalized to a unit+-- vector.  However, if the 2D vector is 0, default it to 0,1 (the forward2+-- vector).+--+-- The new y axis is the argument provided.+--+-- The new z axis is Vec2 (Vec2 (y^.x3) (y^.y2)) (y^.z3) similarly rotated 90+-- degrees counter-clockwise, where the sub-vector has an ‘r2’ view (it scales+-- in number).  (This is like multiplying that vector by ‘i’ in complex number+-- representation.)+tilt3ySimple :: (Floating a, Num a, Fractional a, RealFloat a, SmallNum a) => Vec3 a -> Mat3 a+tilt3ySimple y_ = Mat3 $ Vec3+	-- new x axis           new y axis  new z axis+	( Vec3 ( y'^.y3 / yhr') (y^.x3)     (-(y'^.x3/yhr')*(y^.z3)) )+	( Vec3 (-y'^.x3 / yhr') (y^.y3)     (-(y'^.y3/yhr')*(y^.z3)) )+	( Vec3 0.0              (y^.z3)     (yhr                   ) )+	where+		sq_ a = a * a+		y = v3normalize y_+		yhr = Vec2 (y^.x3) (y^.y3) ^. r2+		yhr' = Vec2 (y'^.x3) (y'^.y3) ^. r2  -- = sqrt $ sq_ y^.x3 + sq_ y^.y3  -- normalizes new x axis+		--yh = Vec2 (y'^.x3) (y'^.y3) -- The 2D vector mentioned above.+		--yhr = yh^. r2  -- = sqrt $ sq_ y^.x3 + sq_ y^.y3  -- normalizes new x axis++		-- y': this handles the special case of y==0,0,±1, where the new x axis should be 1,0,0, (and the new z axis should be 0,∓1,0).+		y' | sqrt (sq_ (y^.x3) + sq_ (y^.y3)) <= smallNum = Vec3 0.0 1.0 0.0 | otherwise = y+		-- TODO: tilt3z probably needs fixes too++tilt3yReverse :: (Floating a, Num a, Fractional a, RealFloat a, SmallNum a) => Vec3 a -> Mat4 a+tilt3yReverse = m3to4 . tilt3yReverseSimple++tilt3yReverseSimple :: (Floating a, Num a, Fractional a, RealFloat a, SmallNum a) => Vec3 a -> Mat3 a+tilt3yReverseSimple (Vec3 x y z) = tilt3ySimple $ Vec3 (-x) y (-z)++-- | Rotate x radians about the axis pointing in direction, which intersects the origin.+--+-- One way to solve this is to compose tilting to the axis, then rotating the x+-- and y axes (w/ x axis cos t, sin t; y axis -sin t, cos t), and then reversing+-- the tilt, and then simplifying the result.+--+-- First, take the tilt to the axis, M0:+--+-- 	(Vec3 (sqrt$ 1 - sq (z^.x3)) 0.0                    (z^.x3))+-- 	(Vec3 0.0                    (sqrt$ 1 - sq (z^.y3)) (z^.y3))+-- 	(Vec3 (            -(z^.x3)) (            -(z^.y3)) (z^.z3))+--+-- Then take the xy rotate about theta, M1:+-- 	(Vec3 (cos t)  (-sin t)  0.0)+-- 	(Vec3 (sin t)  ( cos t)  0.0)+-- 	(Vec3 0.0      0.0       1.0)+--+-- Now take M1*M0:+-- 	(Vec3 ((sqrt$ 1 - sq (z^.x3)) * cos t) (-(sqrt$ 1 - sq (z^.y3)) * sin t) ((z^.x3) * cos t - (z^.y3) * sin t))+-- 	(Vec3 ((sqrt$ 1 - sq (z^.x3)) * sin t) ( (sqrt$ 1 - sq (z^.y3)) * cos t) ((z^.x3) * sin t + (z^.y3) * cos t))+-- 	(Vec3 (-(z^.x3))                       (-(z^.y3))                        (z^.z3)                            )+--+-- Now take M2, reverse tilt:+-- 	(Vec3 (sqrt$ 1 - sq (z^.x3)) 0.0                    (-(z^.x3)))+-- 	(Vec3 0.0                    (sqrt$ 1 - sq (z^.y3)) (-(z^.y3)))+-- 	(Vec3 (             (z^.x3)) (             (z^.y3)) (  z^.z3))+--+-- Now take M2*(M1*M0):+-- 	-- new x axis                                                                                                 new y axis                                                                                                    new z axis+-- 	(Vec3 ((sqrt$ 1 - sq (z^.x3)) * cos t * (sqrt$ 1 - sq (z^.x3))                             + (z^.x3)*(z^.x3)) ((-(sqrt$ 1 - sq (z^.y3)) * sin t) * (sqrt$ 1 - sq (z^.x3))                                + (z^.y3)*(z^.x3)) (((z^.x3) * cos t - (z^.y3) * sin t) * (sqrt$ 1 - sq (z^.x3))                                  - (z^.z3)*(z^.x3)))+-- 	(Vec3 ((sqrt$ 1 - sq (z^.x3)) * sin t * (sqrt$ 1 - sq (z^.y3))                             + (z^.x3)*(z^.y3)) (( (sqrt$ 1 - sq (z^.y3)) * cos t) * (sqrt$ 1 - sq (z^.y3))                                + (z^.y3)*(z^.y3)) (((z^.x3) * sin t + (z^.y3) * cos t) * (sqrt$ 1 - sq (z^.y3))                                  - (z^.z3)*(z^.y3)))+-- 	(Vec3 ((sqrt$ 1 - sq (z^.x3)) * cos t * (z^.x3) + (sqrt$ 1 - sq (z^.x3)) * sin t * (z^.y3) - (z^.x3)*(z^.z3)) ((-(sqrt$ 1 - sq (z^.y3)) * sin t) * (z^.x3) + ( (sqrt$ 1 - sq (z^.y3)) * cos t) * (z^.y3) - (z^.y3)*(z^.z3)) (((z^.x3) * cos t - (z^.y3) * sin t) * (z^.x3) + ((z^.x3) * sin t + (z^.y3) * cos t) * (z^.y3) + (z^.z3)*(z^.z3)))+--+-- Now simplify/rearrange M2*M1*M0:+-- 	-- new x axis                                                                          new y axis                                                                          new z axis+-- 	(Vec3 ((      1 - sq (z^.x3)) * cos t                               + (z^.x3)*(z^.x3)) ((-(sqrt$ 1 - sq (z^.y3)) * sin t) * (sqrt$ 1 - sq (z^.x3))      + (z^.y3)*(z^.x3)) (((z^.x3) * cos t - (z^.y3) * sin t) * (sqrt$ 1 - sq (z^.x3))                                  - (z^.z3)*(z^.x3)))+-- 	(Vec3 ((sqrt$ 1 - sq (z^.x3)) * sin t * (sqrt$ 1 - sq (z^.y3))      + (z^.x3)*(z^.y3)) (  (      1 - sq (z^.y3)) * cos t                                + (z^.y3)*(z^.y3)) (((z^.x3) * sin t + (z^.y3) * cos t) * (sqrt$ 1 - sq (z^.y3))                                  - (z^.z3)*(z^.y3)))+-- 	(Vec3 ((sqrt$ 1 - sq (z^.x3)) * (cos t * (z^.x3) + sin t * (z^.y3)) - (z^.x3)*(z^.z3)) (  (sqrt$ 1 - sq (z^.y3)) * (-sin t * (z^.x3) + cos t * (z^.y3)) - (z^.y3)*(z^.z3)) (((z^.x3) * cos t - (z^.y3) * sin t) * (z^.x3) + ((z^.x3) * sin t + (z^.y3) * cos t) * (z^.y3) + (z^.z3)*(z^.z3)))+--+-- This is our rotation matrix.+--+-- I hope I didn't make a mistake somewhere.+rotate3 :: (Fractional a, RealFloat a) => SimpleRotation a -> Mat4 a+rotate3 = m3to4 . rotate3Simple++-- | Rotate x radians about the axis pointing in direction, which intersects the origin.+rotate3Simple :: (RealFloat a, Floating a) => SimpleRotation a -> Mat3 a+rotate3Simple sr = rotate3Simple_ $ sr & (srOriginAxis %~ v3orWith (Vec3 0.0 0.0 1.0) . v3normalize)++-- | Skip normalizing the axis and assume it's already normal.+rotate3Simple_ :: (Num a, Floating a) => SimpleRotation a -> Mat3 a+rotate3Simple_ sr = Mat3 $ Vec3+	-- new x axis                       new y axis                      new z axis+	(Vec3 (x'_ * c               + x*x) (-y'  * s * x'           + y*x) ((x * c - y * s) * x'                      - z*x))+	(Vec3 (x'  * s * y'          + x*y) ( y'_ * c                + y*y) ((x * s + y * c) * y'                      - z*y))+	(Vec3 (x'  * (c * x + s * y) - x*z) ( y'  * (-s * x + c * y) - y*z) ((x * c - y * s) * x + (x * s + y * c) * y + z*z))+	where+		sq_ a = a*a+		x = zaxis^.x3+		y = zaxis^.y3+		z = zaxis^.z3+		zaxis = sr^.srOriginAxis+		t = sr^.srCcwAngle+		c = cos t+		s = sin t+		x'_ = 1 - sq_ x+		y'_ = 1 - sq_ y+		x' = sqrt $ x'_+		y' = sqrt $ y'_++-- | Uses homogeneous coordinates on top of 3 dimensions.+identityTransformation3 :: (Fractional a) => Mat4 a+identityTransformation3 = Mat4 $ Vec4+	(Vec4 1.0 0.0 0.0 0.0)+	(Vec4 0.0 1.0 0.0 0.0)+	(Vec4 0.0 0.0 1.0 0.0)+	(Vec4 0.0 0.0 0.0 1.0)++-- | Does not use homogeneous coordinates on top of 3 dimensions.+identityTransformation3Simple :: (Fractional a) => Mat3 a+identityTransformation3Simple = Mat3 $ Vec3+	(Vec3 1.0 0.0 0.0)+	(Vec3 0.0 1.0 0.0)+	(Vec3 0.0 0.0 1.0)++rotatexy :: (Floating a) => a -> Mat4 a+rotatexy = m3to4 . rotatexySimple++rotatexz :: (Floating a) => a -> Mat4 a+rotatexz = m3to4 . rotatexzSimple++rotateyz :: (Floating a) => a -> Mat4 a+rotateyz = m3to4 . rotateyzSimple++-- | Aim left: spin (CW) to the right.+--+-- (When the world is spinning clockwise, it looks like you are aiming left.)+rotatexySimple :: (Floating a) => a -> Mat3 a+rotatexySimple t = Mat3 $ Vec3+	(Vec3 c    s   0.0)+	(Vec3 (-s) c   0.0)+	(Vec3 0.0  0.0 1.0)+	where (c, s) = (cos t, sin t)++-- | Tilt the axes right.+rotatexzSimple :: (Floating a) => a -> Mat3 a+rotatexzSimple t = Mat3 $ Vec3+	(Vec3 c    0.0 s  )+	(Vec3 0.0  1.0 0.0)+	(Vec3 (-s) 0.0 c  )+	where (c, s) = (cos t, sin t)++-- | Aim up: move e.g. y axis down.+--+-- (When the world is being rotated downward, it looks like you are aiming up.)+rotateyzSimple :: (Floating a) => a -> Mat3 a+rotateyzSimple t = Mat3 $ Vec3+	(Vec3 1.0 0.0  0.0)+	(Vec3 0.0 c    s  )+	(Vec3 0.0 (-s) c  )+	where (c, s) = (cos t, sin t)++-- | For each on the first row, multiply the element by the determinent of the+-- submatrix modulo width, to the base case of a 2x2 matrix.  Sum.+-- If you ignored sign then 1x1 could be the base case.+--+-- TODO: double check and probably fix this; implementation might be incorrect.+determinant4 :: (Num a) => Mat4 a -> a+determinant4 (Mat4 (Vec4+		(Vec4 v0_0 v0_1 v0_2 v0_3)+		(Vec4 v1_0 v1_1 v1_2 v1_3)+		(Vec4 v2_0 v2_1 v2_2 v2_3)+		(Vec4 v3_0 v3_1 v3_2 v3_3)+	)) =+		v0_0*(v1_1*(v2_2*v3_3 - v2_3*v3_2) + v1_2*(v2_3*v3_1 - v2_1*v3_3) + v1_3*(v2_1*v3_2 - v2_2*v3_1)) ++		v0_1*(v1_2*(v2_3*v3_4 - v2_4*v3_3) + v1_3*(v2_4*v3_2 - v2_2*v3_4) + v1_4*(v2_2*v3_3 - v2_3*v3_2)) ++		v0_2*(v1_3*(v2_4*v3_5 - v2_5*v3_4) + v1_4*(v2_5*v3_3 - v2_3*v3_5) + v1_5*(v2_3*v3_4 - v2_4*v3_3)) ++		v0_3*(v1_4*(v2_5*v3_6 - v2_6*v3_5) + v1_5*(v2_6*v3_4 - v2_4*v3_6) + v1_6*(v2_4*v3_5 - v2_5*v3_4))+	where+		(Vec4 _v0_4 _v0_5 _v0_6 _v0_7) = (Vec4 v0_0 v0_1 v0_2 v0_3)+		(Vec4  v1_4  v1_5  v1_6 _v1_7) = (Vec4 v1_0 v1_1 v1_2 v1_3)+		(Vec4  v2_4  v2_5  v2_6 _v2_7) = (Vec4 v2_0 v2_1 v2_2 v2_3)+		(Vec4  v3_4  v3_5  v3_6 _v3_7) = (Vec4 v3_0 v3_1 v3_2 v3_3)++-- | TODO: document.+--+-- TODO: double check and probably fix this; implementation might be incorrect.+determinant3 :: (Num a) => Mat3 a -> a+determinant3 (Mat3 (Vec3+		(Vec3 v0_0 v0_1 v0_2)+		(Vec3 v1_0 v1_1 v1_2)+		(Vec3 v2_0 v2_1 v2_2)+	)) = v0_0*(v1_1*v2_2 - v1_2*v2_1) + v0_1*(v1_2*v2_0 - v1_0*v2_2) + v0_2*(v1_0*v2_1 - v1_1*v2_0)++smalld :: Double+smalld = 0.001**64++smallf :: Float+smallf = 0.001**12++class SmallNum a where smallNum :: a+instance {-# OVERLAPPING  #-} SmallNum Double where smallNum = smalld+instance {-# OVERLAPPING  #-} SmallNum Float where smallNum = smallf+instance {-# OVERLAPPABLE #-} (Fractional a) => SmallNum a where smallNum = realToFrac $ smallf++equivalentSmall :: (SmallNum a, Ord a, Num a) => a -> a -> Bool+equivalentSmall x y = abs (y - x) <= smallNum++eq2 :: (SmallNum a, Ord a, Num a, RealFloat a) => Vec2 a -> Vec2 a -> Bool+eq2 a b = (b - a)^.r2 <= smallNum++eq3 :: (SmallNum a, Ord a, Num a, RealFloat a) => Vec3 a -> Vec3 a -> Bool+eq3 a b = (b - a)^.r3 <= smallNum++eq4 :: (SmallNum a, Ord a, Num a, RealFloat a) => Vec4 a -> Vec4 a -> Bool+eq4 a b = (b - a)^.r4 <= smallNum++eqm3 :: (SmallNum a, Ord a, Num a, RealFloat a) => Mat3 a -> Mat3 a -> Bool+eqm3 a b = let (Mat3 rows) = abs <$> ((-) <$> b <*> a) in ((^.r3) <$> rows)^.r3 <= smallNum++eqm4 :: (SmallNum a, Ord a, Num a, RealFloat a) => Mat4 a -> Mat4 a -> Bool+eqm4 a b = let (Mat4 rows) = abs <$> ((-) <$> b <*> a) in ((^.r4) <$> rows)^.r4 <= smallNum++smallishd :: Double+smallishd = 0.1**05++smallishf :: Float+smallishf = 0.1**05++class SmallishNum a where smallishNum :: a+instance {-# OVERLAPPING  #-} SmallishNum Double where smallishNum = smallishd+instance {-# OVERLAPPING  #-} SmallishNum Float where smallishNum = smallishf+instance {-# OVERLAPPABLE #-} (Fractional a) => SmallishNum a where smallishNum = realToFrac $ smallishf++near :: (SmallishNum a, Ord a, Num a) => a -> a -> Bool+near x y = abs (y - x) <= smallishNum++near2 :: (SmallishNum a, Ord a, Num a, RealFloat a) => Vec2 a -> Vec2 a -> Bool+near2 a b = (b - a)^.r2 <= smallishNum++near3 :: (SmallishNum a, Ord a, Num a, RealFloat a) => Vec3 a -> Vec3 a -> Bool+near3 a b = (b - a)^.r3 <= smallishNum++near4 :: (SmallishNum a, Ord a, Num a, RealFloat a) => Vec4 a -> Vec4 a -> Bool+near4 a b = (b - a)^.r4 <= smallishNum++nearm3 :: (SmallishNum a, Ord a, Num a, RealFloat a) => Mat3 a -> Mat3 a -> Bool+nearm3 a b = let (Mat3 rows) = abs <$> ((-) <$> b <*> a) in ((^.r3) <$> rows)^.r3 <= smallishNum++nearm4 :: (SmallishNum a, Ord a, Num a, RealFloat a) => Mat4 a -> Mat4 a -> Bool+nearm4 a b = let (Mat4 rows) = abs <$> ((-) <$> b <*> a) in ((^.r4) <$> rows)^.r4 <= smallishNum++rankNonzerov4 :: (SmallNum a, Ord a, Num a) => Vec4 a -> Integer+rankNonzerov4 (Vec4 x y z w)+	| abs x > smallNum = 4+	| abs y > smallNum = 3+	| abs z > smallNum = 2+	| abs w > smallNum = 1+	| otherwise        = 0++rankNonzerov3 :: (SmallNum a, Ord a, Num a) => Vec3 a -> Integer+rankNonzerov3 (Vec3 x y z)+	| abs x > smallNum = 3+	| abs y > smallNum = 2+	| abs z > smallNum = 1+	| otherwise        = 0++sortRowsRankNonzerom4 :: (SmallNum a, Ord a, Num a) => Mat4 a -> Mat4 a+sortRowsRankNonzerom4 (Mat4 (Vec4 r0 r1 r2_ r3_)) =+	-- Merge sort.+	if' (rn0 <= rn1) (+		if' (rn2 <= rn3) (+			-- Now merge (max 3 comparisons).+			if' (rn0 <= rn2) (+				if' (rn1 <= rn2) (+					m4 r0 r1 r2_ r3_+				) (+					if' (rn1 <= rn3) (m4 r0 r2_ r1 r3_) (m4 r0 r2_ r3_ r1)+				)+			) (+				if' (rn0 <= rn3) (+					if' (rn1 <= rn3) (m4 r2_ r0 r1 r3_) (m4 r2_ r0 r3_ r1)+				) (+					m4 r2_ r3_ r0 r1+				)+			)+		) (+			-- Copy and swap r3_ and r2_.+			if' (rn0 <= rn3) (+				if' (rn1 <= rn3) (+					m4 r0 r1 r3_ r2_+				) (+					if' (rn1 <= rn2) (m4 r0 r3_ r1 r2_) (m4 r0 r3_ r2_ r1)+				)+			) (+				if' (rn0 <= rn2) (+					if' (rn1 <= rn2) (m4 r3_ r0 r1 r2_) (m4 r3_ r0 r2_ r1)+				) (+					m4 r3_ r2_ r0 r1+				)+			)+		)+	) (+		-- Copy and swap r0 and r1.+		if' (rn2 <= rn3) (+			if' (rn1 <= rn2) (+				if' (rn0 <= rn2) (+					m4 r0 r1 r2_ r3_+				) (+					if' (rn0 <= rn3) (m4 r0 r2_ r1 r3_) (m4 r0 r2_ r3_ r1)+				)+			) (+				if' (rn1 <= rn3) (+					if' (rn0 <= rn3) (m4 r2_ r0 r1 r3_) (m4 r2_ r0 r3_ r1)+				) (+					m4 r2_ r3_ r0 r1+				)+			)+		) (+			if' (rn1 <= rn3) (+				if' (rn0 <= rn3) (+					m4 r0 r1 r3_ r2_+				) (+					if' (rn0 <= rn2) (m4 r0 r3_ r1 r2_) (m4 r0 r3_ r2_ r1)+				)+			) (+				if' (rn1 <= rn2) (+					if' (rn0 <= rn2) (m4 r3_ r0 r1 r2_) (m4 r3_ r0 r2_ r1)+				) (+					m4 r3_ r2_ r0 r1+				)+			)+		)+	)+	where+		rn0 = -rankNonzerov4 r0+		rn1 = -rankNonzerov4 r1+		rn2 = -rankNonzerov4 r2_+		rn3 = -rankNonzerov4 r3_+		m4 r0_ r1_ r2_2 r3__ = Mat4 $ Vec4 r0_ r1_ r2_2 r3__++sortRowsRankNonzerom3 :: (SmallNum a, Ord a, Num a) => Mat3 a -> Mat3 a+sortRowsRankNonzerom3 (Mat3 (Vec3 r0 r1 r2_)) =+	if' (rn0 <= rn1) (+		if' (rn1 <= rn2) (+			m3 r0 r1 r2_+		) (+			if' (rn0 <= rn2) (m3 r0 r2_ r1) (m3 r2_ r1 r0)+		)+	) (+		if' (rn0 <= rn2) (+			m3 r1 r0 r2_+		) (+			if' (rn1 <= rn2) (m3 r1 r2_ r0) (m3 r2_ r0 r1)+		)+	)+	where+		rn0 = -rankNonzerov3 r0+		rn1 = -rankNonzerov3 r1+		rn2 = -rankNonzerov3 r2_+		m3 r0_ r1_ r2_2 = Mat3 $ Vec3 r0_ r1_ r2_2++inversem4 :: (SmallNum a, Ord a, Num a, Fractional a) => Mat4 a -> Mat4 a+inversem4 = inversem4GaussianElimination++inversem3 :: (SmallNum a, Ord a, Num a, Fractional a) => Mat3 a -> Mat3 a+inversem3 = inversem3GaussianElimination++-- | Inverse.  Method by Gaussian elimination.  Non-zero determinant will avoid+-- divide by zero in the matrix, since then the vectors are linearly+-- independent without a vector to ‘collapse’ the hypervolume by multiplying by 0.+--+-- 	(Vec4 v0_0 v0_1 v0_2 v0_3) (Vec4 1.0 0.0 0.0 0.0)+-- 	(Vec4 v1_0 v1_1 v1_2 v1_3) (Vec4 0.0 1.0 0.0 0.0)+-- 	(Vec4 v2_0 v2_1 v2_2 v2_3) (Vec4 0.0 0.0 1.0 0.0)+-- 	(Vec4 v3_0 v3_1 v3_2 v3_3) (Vec4 0.0 0.0 0.0 1.0)+--+-- 	(Vec4 v0_0 v0_1 v0_2 v0_3)+-- 	(Vec4 0.0  v1_1 v1_2 v1_3)  - (v1_0/v0_0)*r0+-- 	(Vec4 0.0  v2_1 v2_2 v2_3)  - (v2_0/v0_0)*r0+-- 	(Vec4 0.0  v3_1 v3_2 v3_3)  - (v3_0/v0_0)*r0+--+-- 	(Vec4 v0_0 v0_1 v0_2 v0_3)+-- 	(Vec4 0.0  v1_1 v1_2 v1_3)+-- 	(Vec4 0.0  0.0  v2_2 v2_3)  - (v2_1/v1_1)*r1+-- 	(Vec4 0.0  0.0  v3_2 v3_3)  - (v3_1/v1_1)*r1+--+-- 	(Vec4 v0_0 v0_1 v0_2 v0_3)+-- 	(Vec4 0.0  v1_1 v1_2 v1_3)+-- 	(Vec4 0.0  0.0  v2_2 v2_3)+-- 	(Vec4 0.0  0.0  0.0  v3_3)  - (v3_2/v2_2)*r2+--+-- 	(Vec4 v0_0 v0_1 v0_2 0.0 )  - (v0_3/v3_3)*r3+-- 	(Vec4 0.0  v1_1 v1_2 0.0 )  - (v1_3/v3_3)*r3+-- 	(Vec4 0.0  0.0  v2_2 0.0 )  - (v2_3/v3_3)*r3+-- 	(Vec4 0.0  0.0  0.0  v3_3)+--+-- 	(Vec4 v0_0 v0_1 0.0  0.0 )  - (v0_2/v2_2)*r2+-- 	(Vec4 0.0  v1_1 0.0  0.0 )  - (v1_2/v2_2)*r2+-- 	(Vec4 0.0  0.0  v2_2 0.0 )+-- 	(Vec4 0.0  0.0  0.0  v3_3)+--+-- 	(Vec4 v0_0 0.0  0.0  0.0 )  - (v0_1/v1_1)*r1+-- 	(Vec4 0.0  v1_1 0.0  0.0 )+-- 	(Vec4 0.0  0.0  v2_2 0.0 )+-- 	(Vec4 0.0  0.0  0.0  v3_3)+--+-- 	(Vec4 1.0 0.0 0.0 0.0)  - / v0_0+-- 	(Vec4 0.0 1.0 0.0 0.0)  - / v1_1+-- 	(Vec4 0.0 0.0 1.0 0.0)  - / v2_2+-- 	(Vec4 0.0 0.0 0.0 1.0)  - / v3_3+--+-- Between each 0 operation there is a sort.+--+-- Now apply these operations to the identity matrix to get the inverse.+inversem4GaussianElimination :: (SmallNum a, Ord a, Num a, Fractional a) => Mat4 a -> Mat4 a+inversem4GaussianElimination m =+	b sortRowsRankNonzerom4 >>> (\(mn, mi) -> (+		b (r1_4 %~ (`minusv4` (((mn^.e1_0_4)/(mn^.e0_0_4)) `sv4` (mn^.r0_4)))) >>>+		b (r2_4 %~ (`minusv4` (((mn^.e2_0_4)/(mn^.e0_0_4)) `sv4` (mn^.r0_4)))) >>>+		b (r3_4 %~ (`minusv4` (((mn^.e3_0_4)/(mn^.e0_0_4)) `sv4` (mn^.r0_4))))+		) $ (mn, mi)) >>>+	b sortRowsRankNonzerom4 >>> (\(mn, mi) -> (+		b (r2_4 %~ (`minusv4` (((mn^.e2_1_4)/(mn^.e1_1_4)) `sv4` (mn^.r1_4)))) >>>+		b (r3_4 %~ (`minusv4` (((mn^.e3_1_4)/(mn^.e1_1_4)) `sv4` (mn^.r1_4))))+		) $ (mn, mi)) >>>+	b sortRowsRankNonzerom4 >>> (\(mn, mi) -> (+		b (r3_4 %~ (`minusv4` (((mn^.e3_2_4)/(mn^.e2_2_4)) `sv4` (mn^.r2_4))))+		) $ (mn, mi)) >>>++	(\(mn, mi) -> (+		b (r0_4 %~ (`minusv4` (((mn^.e0_3_4)/(mn^.e3_3_4)) `sv4` (mn^.r3_4)))) >>>+		b (r1_4 %~ (`minusv4` (((mn^.e1_3_4)/(mn^.e3_3_4)) `sv4` (mn^.r3_4)))) >>>+		b (r2_4 %~ (`minusv4` (((mn^.e2_3_4)/(mn^.e3_3_4)) `sv4` (mn^.r3_4))))+		) $ (mn, mi)) >>>+	(\(mn, mi) -> (+		b (r0_4 %~ (`minusv4` (((mn^.e0_2_4)/(mn^.e2_2_4)) `sv4` (mn^.r2_4)))) >>>+		b (r1_4 %~ (`minusv4` (((mn^.e1_2_4)/(mn^.e2_2_4)) `sv4` (mn^.r2_4))))+		) $ (mn, mi)) >>>+	(\(mn, mi) -> (+		b (r0_4 %~ (`minusv4` (((mn^.e0_1_4)/(mn^.e1_1_4)) `sv4` (mn^.r1_4))))+		) $ (mn, mi)) >>>++	(\(mn, mi) -> (+		b (r0_4 %~ ((1/(mn^.e0_0_4)) `sv4`)) >>>+		b (r1_4 %~ ((1/(mn^.e1_1_4)) `sv4`)) >>>+		b (r2_4 %~ ((1/(mn^.e2_2_4)) `sv4`)) >>>+		b (r3_4 %~ ((1/(mn^.e3_3_4)) `sv4`))+		) $ (mn, mi)) >>>++	snd $ (m, (+		Mat4 $ Vec4+			(Vec4 1.0 0.0 0.0 0.0)+			(Vec4 0.0 1.0 0.0 0.0)+			(Vec4 0.0 0.0 1.0 0.0)+			(Vec4 0.0 0.0 0.0 1.0)+	))+	where b = join (***)++inversem3GaussianElimination :: (SmallNum a, Ord a, Num a, Fractional a) => Mat3 a -> Mat3 a+inversem3GaussianElimination m =+	b sortRowsRankNonzerom3 >>> (\(mn, mi) -> (+		b (r1_3 %~ (`minusv3` (((mn^.e1_0_3)/(mn^.e0_0_3)) `sv3` (mn^.r0_3)))) >>>+		b (r2_3 %~ (`minusv3` (((mn^.e2_0_3)/(mn^.e0_0_3)) `sv3` (mn^.r0_3))))+		) $ (mn, mi)) >>>+	b sortRowsRankNonzerom3 >>> (\(mn, mi) -> (+		b (r2_3 %~ (`minusv3` (((mn^.e2_1_3)/(mn^.e1_1_3)) `sv3` (mn^.r1_3))))+		) $ (mn, mi)) >>>++	(\(mn, mi) -> (+		b (r0_3 %~ (`minusv3` (((mn^.e0_2_3)/(mn^.e2_2_3)) `sv3` (mn^.r2_3)))) >>>+		b (r1_3 %~ (`minusv3` (((mn^.e1_2_3)/(mn^.e2_2_3)) `sv3` (mn^.r2_3))))+		) $ (mn, mi)) >>>+	(\(mn, mi) -> (+		b (r0_3 %~ (`minusv3` (((mn^.e0_1_3)/(mn^.e1_1_3)) `sv3` (mn^.r1_3))))+		) $ (mn, mi)) >>>++	(\(mn, mi) -> (+		b (r0_3 %~ ((1/(mn^.e0_0_3)) `sv3`)) >>>+		b (r1_3 %~ ((1/(mn^.e1_1_3)) `sv3`)) >>>+		b (r2_3 %~ ((1/(mn^.e2_2_3)) `sv3`))+		) $ (mn, mi)) >>>++	snd $ (m, (+		Mat3 $ Vec3+			(Vec3 1.0 0.0 0.0)+			(Vec3 0.0 1.0 0.0)+			(Vec3 0.0 0.0 1.0)+	))+	where b = join (***)++-- | perspective.+--+-- e.g. for a simple right-angled fov with a (0,0,1) perspective vector,+-- a point (2,4,1,1) corresponds to (2,4,2,2), which is (1,2,1).  At further+-- distance from the viewer, points should seem smaller (closer to 0 x and y+-- coordinates), so where at z=0 the x and y coordinates effectively remain+-- unchanged, at z=1 they are halved.  And a point (2,4,3,1) is twice as far+-- away as the first point relative to the viewer z=-1 (z=0 is the inner+-- plane), and it corresponds / maps back to coordinates in the original+-- coordinate system (2,4,6,4), which is (0.5, 1, 1.5) after applying homogenous+-- coordinates (divide coords by last coordinate).  (3/2=1.5)  (2z/(z+1))+--+-- A third example is a point (2,4,5,1) mapping back to original axes as+-- (2,4,10,6), which is equivalent to (1/3, 2/3, 5/3 = 1.66…).  It is three+-- times as far away as the first point relative to the viewer z=-1.+perspective :: (Num a, Fractional a) => Vec3 a -> Mat4 a+perspective v = Mat4 $ Vec4+	(Vec4 (1+v^.x3) 0.0       0.0       0.0)+	(Vec4 0.0       (1+v^.y3) 0.0       0.0)+	(Vec4 0.0       0.0       (1+v^.z3) 0.0)+	(Vec4 (v^.x3)   (v^.y3)   (v^.z3)   1.0)++-- | preserves z and does not shift by 1 but is not invertible.+--+-- With linear non-independence, it collapses into 3 dimensions without a nonzero determinant.+perspectivePure :: (Num a, Fractional a) => Vec3 a -> Mat4 a+perspectivePure v = Mat4 $ Vec4+	(Vec4 (1+v^.x3) 0.0       0.0       0.0)+	(Vec4 0.0       (1+v^.y3) 0.0       0.0)+	(Vec4 0.0       0.0       (1+v^.z3) 0.0)+	(Vec4 (v^.x3)   (v^.y3)   (v^.z3)   0.0)++-- | fov.+--+-- For a 2D space with the y coordinate determining distance, with doubling+-- distance halving the other coordinates (x), you can find the the length of+-- the left side of the following triangle knowing angle theta and the length+-- of the top side, which is x, which is 1, where we want to know, for each+-- increase by 1 of the z or y or distance coordinate, what the increase in the+-- homogoneous coordinate w is, where the result of the homogeneous coordinate is+-- (x/w, y/w, z/w).+--+--  ^+--  |--.+--  |  /+--  | /+--  |θ/+--  |/+-- -+----->+--  |+--+-- Then we can generalize to 3 dimensions.+--+-- To preserve the original distance coordinate, .+--+-- Also preserving a nonzero determinant, the perspective is with z shifted+-- back by 1 unit, so that z=0 is not the eye origin, but the inner plane, for+-- a unit w or homogenous coordinate.+--+-- e.g. a right angled fov makes for a z component of 1, for a 1:1 ratio.+fov :: (Fractional a, Floating a) => a -> Mat4 a+fov t = perspective $ Vec3 0.0 (1 / tan (t/2)) 0.0++fovPure :: (Fractional a, Floating a) => a -> Mat4 a+fovPure t = perspectivePure $ Vec3 0.0 (1 / tan (t/2)) 0.0++zv2 :: (Num a) => Vec2 a+zv2 = rv2 0++zv3 :: (Num a) => Vec3 a+zv3 = rv3 0++zv4 :: (Num a) => Vec4 a+zv4 = rv4 0++rm3 :: a -> Mat3 a+rm3 z = Mat3 $ Vec3+	(rv3 z)+	(rv3 z)+	(rv3 z)++rm4 :: a -> Mat4 a+rm4 z = Mat4 $ Vec4+	(rv4 z)+	(rv4 z)+	(rv4 z)+	(rv4 z)++zm3 :: (Fractional a) => Mat3 a+zm3 = rm3 0.0++zm4 :: (Fractional a) => Mat4 a+zm4 = rm4 0.0++type MView = MViewd++type MViewd = MView' Double+data MView' a = MView {+	_mviewPos    :: Vec3 a,+	_mviewTarget :: Vec3 a,+	-- | Whole fov (not half).+	_mviewFov    :: a+}+	deriving (Eq, Ord, Show)+makeLenses ''MView'++-- | Translate, then rotate, then fov.+viewMat :: (Num a, Fractional a, Floating a, RealFloat a, SmallNum a) => MView' a -> Mat4 a+viewMat = viewMat' False++-- | Translate, then rotate, then fov or fovPure.+viewMat' :: (Num a, Fractional a, Floating a, RealFloat a, SmallNum a) => Bool -> MView' a -> Mat4 a+viewMat' viewCollapse v =+	fov'          (v^.mviewFov) <>+	tilt3yReverse ((v^.mviewTarget) `minusv3` (v^.mviewPos)) <>+	translate3    (-v^.mviewPos)+	where+		fov' = if' viewCollapse fovPure fov++-- | Swap y and z axes.+--+-- OpenGL expects z to be ‘forward’ with depth, and y to be vertically, whereas+-- world positioning expects y to be ‘forward’ towards the camera target, and z to+-- be up and down vertically.+worldToGL :: (Num a, Fractional a) => Mat4 a+worldToGL = Mat4 $ Vec4+	(Vec4 1.0 0.0 0.0 0.0)+	(Vec4 0.0 0.0 1.0 0.0)+	(Vec4 0.0 1.0 0.0 0.0)+	(Vec4 0.0 0.0 0.0 1.0)++-- | 'worldToGL' in a 3x3 matrix.+worldToGLSimple :: (Num a, Fractional a) => Mat3 a+worldToGLSimple = Mat3 $ Vec3+	(Vec3 1.0 0.0 0.0)+	(Vec3 0.0 0.0 1.0)+	(Vec3 0.0 1.0 0.0)++-- | Shift and scale the depth value to approximate disabling OpenGL clipping+-- depth values outside a range, so that we can see the whole scene, not only+-- the part of the scene within a certain range of distance from the viewer.+rescaleDepth :: (Num a, Fractional a) => a -> a -> Mat4 a+rescaleDepth depthTranslate depthScale = Mat4 $ Vec4+	(Vec4 1.0 0.0 0.0 0.0)+	(Vec4 0.0 ds  0.0 do_)+	(Vec4 0.0 0.0 1.0 0.0)+	(Vec4 0.0 0.0 0.0 1.0)+	where+		(do_, ds) = (depthTranslate, depthScale)++-- * 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.+aimHoriz3DSimple :: (Num a, Floating a) => a -> Vec3 a -> Vec3 a+aimHoriz3DSimple radiansRight target =+	rotatexySimple radiansRight `mv3` target++-- | The vector represents where the camera at the origin is pointing.+-- Rotate aim up by ‘radiansUp’ radians.+-- Optionally cap absolute result by ‘mmaxRadius’ radians from level where z=0.+aimVert3DSimple :: (Num a, Floating a, RealFloat a, SmallNum a) => Maybe a -> a -> Vec3 a -> Vec3 a+aimVert3DSimple mmaxRadius radiansUp target@(Vec3 tx ty _tz) = (`mv3` target) $+	rotateHorizToTarget <>+	rotateVertically <>+	unrotateHorizToTarget++	where+		-- First horizontally unrotate the point back to 0,1,z so that tx becomes 0 (the point becomes in the yz plane).+		unrotateHorizToTarget = rotatexySimple (-horizCWAngle)+		-- Third rotate horizontally back to restore tx,ty's angle.+		rotateHorizToTarget   = rotatexySimple   horizCWAngle+		-- Second rotate in plane yz around x axis.+		rotateVertically = rotateyzSimple (-radiansUp')++		-- Angle when aiming right.  CW relative to 0,1 in radians.+		-- (If you take a forward vector 0,1,0 and aim right by this angle,+		-- then the result will point in the same direction as 'target'+		-- ignoring the z coordinate.)+		horizCWAngle+			| (Vec2 tx ty ^. r2) `equivalentSmall` 0.0 = 0.0  -- Technically redundant, since rotating in this case would still give you 0,0 for x,y.+			| otherwise                                =+				-((Vec2 tx ty ^. t2) - (Vec2 0.0 1.0 ^. t2))+		---- Negate angle.+		--horizCCWAngle = -horizCWAngle++		-- In order to perform clamping, get a copy of a partially transformed target (only 1st transformation).+		yz = let (Vec3 _x y z) = (`mv3` target) $ unrotateHorizToTarget in Vec2 y z++		maxRadiansUp = fromMaybe (tau/2)  (           mmaxRadius) - (yz^.t2)+		minRadiansUp = fromMaybe (-tau/2) (negate <$> mmaxRadius) - (yz^.t2)++		radiansUp' = case mmaxRadius of+			Nothing -> radiansUp+			Just _ -> min maxRadiansUp . max minRadiansUp $ radiansUp++-- * More utils.++-- | Is the vector zero?+v2z :: (SmallNum a, Ord a, Num a, RealFloat a) => Vec2 a -> Bool+v2z v = equivalentSmall (v^.r2) 0++-- | Is the vector near zero?+v2s :: (SmallishNum a, Ord a, Num a, RealFloat a) => Vec2 a -> Bool+v2s v = near (v^.r2) 0++-- | Return the vector, unless it's zero, in which case return the default.+v2nzElse :: (SmallNum a, Ord a, Num a, RealFloat a) => Vec2 a -> Vec2 a -> Vec2 a+v2nzElse v else_ = if' (not $ v2z v) v else_++-- | Return the vector, unless it's near zero, in which case return the default.+v2nsElse :: (SmallishNum a, Ord a, Num a, RealFloat a) => Vec2 a -> Vec2 a -> Vec2 a+v2nsElse v else_ = if' (not $ v2s v) v else_++-- | Is the vector zero?+v3z :: (SmallNum a, Ord a, Num a, RealFloat a) => Vec3 a -> Bool+v3z v = equivalentSmall (v^.r3) 0++-- | Is the vector near zero?+v3s :: (SmallishNum a, Ord a, Num a, RealFloat a) => Vec3 a -> Bool+v3s v = near (v^.r3) 0++-- | Return the vector, unless it's zero, in which case return the default.+v3nzElse :: (SmallNum a, Ord a, Num a, RealFloat a) => Vec3 a -> Vec3 a -> Vec3 a+v3nzElse v else_ = if' (not $ v3z v) v else_++-- | Return the vector, unless it's near zero, in which case return the default.+v3nsElse :: (SmallishNum a, Ord a, Num a, RealFloat a) => Vec3 a -> Vec3 a -> Vec3 a+v3nsElse v else_ = if' (not $ v3s v) v else_++-- | Is the vector zero?+v4z :: (SmallNum a, Ord a, Num a, RealFloat a) => Vec4 a -> Bool+v4z v = equivalentSmall (v^.r4) 0++-- | Is the vector near zero?+v4s :: (SmallishNum a, Ord a, Num a, RealFloat a) => Vec4 a -> Bool+v4s v = near (v^.r4) 0++-- | Return the vector, unless it's zero, in which case return the default.+v4nzElse :: (SmallNum a, Ord a, Num a, RealFloat a) => Vec4 a -> Vec4 a -> Vec4 a+v4nzElse v else_ = if' (not $ v4z v) v else_++-- | Return the vector, unless it's near zero, in which case return the default.+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.++-- | Handle just the ‘xy’ vector in a Vec3.+xy3 :: forall a. Lens' (Vec3 a) (Vec2 a)+xy3 = lens getter (flip setter)+	where+		getter :: Vec3 a -> Vec2 a+		getter (Vec3 x y _) = Vec2 x y+		setter :: Vec2 a -> Vec3 a -> Vec3 a+		setter (Vec2 x y) (Vec3 _ _ z) = Vec3 x y z++-- | Handle just the ‘xz’ vector in a Vec3.+xz3 :: forall a. Lens' (Vec3 a) (Vec2 a)+xz3 = lens getter (flip setter)+	where+		getter :: Vec3 a -> Vec2 a+		getter (Vec3 x _ z) = Vec2 x z+		setter :: Vec2 a -> Vec3 a -> Vec3 a+		setter (Vec2 x z) (Vec3 _ y _) = Vec3 x y z++-- | Handle just the ‘yz’ vector in a Vec3.+yz3 :: forall a. Lens' (Vec3 a) (Vec2 a)+yz3 = lens getter (flip setter)+	where+		getter :: Vec3 a -> Vec2 a+		getter (Vec3 _ y z) = Vec2 y z+		setter :: Vec2 a -> Vec3 a -> Vec3 a+		setter (Vec2 y z) (Vec3 x _ _) = Vec3 x y z++-- | Handle just the ‘xy’ vector in a Vec4.+xy4 :: forall a. Lens' (Vec4 a) (Vec2 a)+xy4 = lens getter (flip setter)+	where+		getter :: Vec4 a -> Vec2 a+		getter (Vec4 x y _ _) = Vec2 x y+		setter :: Vec2 a -> Vec4 a -> Vec4 a+		setter (Vec2 x y) (Vec4 _ _ z w) = Vec4 x y z w++-- | Handle just the ‘xz’ vector in a Vec4.+xz4 :: forall a. Lens' (Vec4 a) (Vec2 a)+xz4 = lens getter (flip setter)+	where+		getter :: Vec4 a -> Vec2 a+		getter (Vec4 x _ z _) = Vec2 x z+		setter :: Vec2 a -> Vec4 a -> Vec4 a+		setter (Vec2 x z) (Vec4 _ y _ w) = Vec4 x y z w++-- | Handle just the ‘xw’ vector in a Vec4.+xw4 :: forall a. Lens' (Vec4 a) (Vec2 a)+xw4 = lens getter (flip setter)+	where+		getter :: Vec4 a -> Vec2 a+		getter (Vec4 x _ _ w) = Vec2 x w+		setter :: Vec2 a -> Vec4 a -> Vec4 a+		setter (Vec2 x w) (Vec4 _ y z _) = Vec4 x y z w++-- | Handle just the ‘yz’ vector in a Vec4.+yz4 :: forall a. Lens' (Vec4 a) (Vec2 a)+yz4 = lens getter (flip setter)+	where+		getter :: Vec4 a -> Vec2 a+		getter (Vec4 _ y z _) = Vec2 y z+		setter :: Vec2 a -> Vec4 a -> Vec4 a+		setter (Vec2 y z) (Vec4 x _ _ w) = Vec4 x y z w++-- | Handle just the ‘yw’ vector in a Vec4.+yw4 :: forall a. Lens' (Vec4 a) (Vec2 a)+yw4 = lens getter (flip setter)+	where+		getter :: Vec4 a -> Vec2 a+		getter (Vec4 _ y _ w) = Vec2 y w+		setter :: Vec2 a -> Vec4 a -> Vec4 a+		setter (Vec2 y w) (Vec4 x _ z _) = Vec4 x y z w++-- | Handle just the ‘zw’ vector in a Vec4.+zw4 :: forall a. Lens' (Vec4 a) (Vec2 a)+zw4 = lens getter (flip setter)+	where+		getter :: Vec4 a -> Vec2 a+		getter (Vec4 _ _ z w) = Vec2 z w+		setter :: Vec2 a -> Vec4 a -> Vec4 a+		setter (Vec2 z w) (Vec4 x y _ _) = Vec4 x y z w++-- | Handle just the ‘xyz’ vector in a Vec4.+xyz4 :: forall a. Lens' (Vec4 a) (Vec3 a)+xyz4 = lens getter (flip setter)+	where+		getter :: Vec4 a -> Vec3 a+		getter (Vec4 x y z _) = Vec3 x y z+		setter :: Vec3 a -> Vec4 a -> Vec4 a+		setter (Vec3 x y z) (Vec4 _ _ _ w) = Vec4 x y z w++-- | Handle just the ‘xyw’ vector in a Vec4.+xyw4 :: forall a. Lens' (Vec4 a) (Vec3 a)+xyw4 = lens getter (flip setter)+	where+		getter :: Vec4 a -> Vec3 a+		getter (Vec4 x y _ w) = Vec3 x y w+		setter :: Vec3 a -> Vec4 a -> Vec4 a+		setter (Vec3 x y w) (Vec4 _ _ z _) = Vec4 x y z w++-- | Handle just the ‘xzw’ vector in a Vec4.+xzw4 :: forall a. Lens' (Vec4 a) (Vec3 a)+xzw4 = lens getter (flip setter)+	where+		getter :: Vec4 a -> Vec3 a+		getter (Vec4 x _ z w) = Vec3 x z w+		setter :: Vec3 a -> Vec4 a -> Vec4 a+		setter (Vec3 x z w) (Vec4 _ y _ _) = Vec4 x y z w++-- | Handle just the ‘yzw’ vector in a Vec4.+yzw4 :: forall a. Lens' (Vec4 a) (Vec3 a)+yzw4 = lens getter (flip setter)+	where+		getter :: Vec4 a -> Vec3 a+		getter (Vec4 _ y z w) = Vec3 y z w+		setter :: Vec3 a -> Vec4 a -> Vec4 a+		setter (Vec3 y z w) (Vec4 x _ _ _) = Vec4 x y z w++-- | Convenient utility to square a number.+sqx :: forall a. (Num a) => a -> a+sqx x = x*x
+ Immutaball/Share/Math/X3D.hs view
@@ -0,0 +1,560 @@+{-# 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 #-}++-- State.hs.++{-# LANGUAGE Haskell2010 #-}+{-# LANGUAGE TemplateHaskell, DerivingVia, ScopedTypeVariables #-}++-- | 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.+module Immutaball.Share.Math.X3D+	(+		Plane3(..), unPlane3,+		normalPlane3,+		abcdp3,+		abcp3,+		dp3,++		defaultOrientationPlane3,+		plane3PointDistance,+		pointToPlane,+		plane3ReflectPoint,+		plane3ReflectPointAmount,+		normalizePlane3,+		negatePlaneOrientation,++		Line3(..), p0l3, p1l3,+		line3Points,+		line3Axes,+		ol3,+		a0l3,+		line3NormalizeDisplacement,+		line3DistanceFromOrigin,++		plane3LineSegmentDistance,+		line3AxisReflectPlane3,++		line3Lerp,+		line3CoordAtDistancePlane3,++		line3PointCoord,+		line3PointDistance,+		line3DistanceCoordFromPoint,+		line3Line3ClosestCoords,+		line3Line3Distance,++		eqPlane3,+		eqLine3,+		nearPlane3,+		nearLine3,++		eqPlane3PointsOnly,+		eqLine3PointsOnly,+		nearPlane3PointsOnly,+		nearLine3PointsOnly,++		QCurve3(..), a2q3, a1q3, a0q3,+		qcurve3,+		qcurvePath3,+		pathq3,+		qcurve3Qerp,+		qcurve3Vel,+		qcurve3Accel+	) where++import Prelude ()+import Immutaball.Prelude++import Control.Lens++import Immutaball.Share.Math.Core++-- | Normal, distance.+--+-- > ax + by + cd = d+--+-- abc is the unit normal vector, and d is the distance of the plane from the+-- origin.  The dot product of a point onto the unit normal projects onto it+-- and must be equal to the plane's closest distance from the origin.+newtype Plane3 a = Plane3 { _unPlane3 :: Vec4 a }+	deriving (Eq, Ord, Show)+		via (Vec4 a)+makeLenses ''Plane3++-- | Construct a plane from a unit normal (unit-lengthedness unverified) and a+-- distance from the origin.+normalPlane3 :: forall a. (Num a) => Vec3 a -> a -> Plane3 a+normalPlane3 abc d = Plane3 $ Vec4 (abc^.x3) (abc^.y3) (abc^.z3) d++-- | Unit-lengthedness of the normal is not verified.+abcdp3 :: forall a. Lens' (Plane3 a) (Vec4 a)+abcdp3 = lens getter (flip setter)+	where+		getter :: Plane3 a -> Vec4 a+		getter (Plane3 v) = v+		setter :: Vec4 a -> Plane3 a -> Plane3 a+		setter v _ = Plane3 v++-- | Plane normal lens.+abcp3 :: forall a. Lens' (Plane3 a) (Vec3 a)+abcp3 = abcdp3.xyz4++-- | Plane distance lens.+dp3 :: forall a. Lens' (Plane3 a) a+dp3 = abcdp3.w4++-- | Obtain a default ‘orientation’ (new axes in a transformation matrix, each+-- of which is orthogonal to each) for a plane by using a pattern that is like+-- a determinent (for that next axis) of increasing dimensionality for each+-- next axis for a hyperplane, copying from the initial axis for the remaining+-- components.  For a plane, we use the normal as the initial axis for the+-- derivation of the remaining axes.  (e.g. apply a determinant-like procedure+-- for a 2x2 matrix (copy coords 3 and later from initial), for the next axis,+-- then for the one after, 3x3 (copy coords 4 and later), then 4x4, etc.)  This+-- will also derive identity matrices.  It a generalization of cross product.+--+-- > a x x+-- > b x x+-- > c x x+--+-- > a -b  x+-- > b  a  x+-- > c  c  x  (Copy c, d, e, …, for the second axis.  -b and a come from the determinent-like procedure of increasing dimensionality.)+--+-- > a -b  ( bc - ac)+-- > b  a  (-ac - bc)+-- > c  c  (a^2 + b^2)+--+-- (Currently lacking a dependently typed proof, which would also help verify+-- correctness.)+--+-- The non-first columns can be used to project 2D points onto the plane, with+-- the _scaled_ normal (d * abc) in the translation column if homogenous+-- coordinatse are added.  This projection matrix would be 4x3, projecting 2D+-- points into 3D space on the plane.+defaultOrientationPlane3 :: forall a. (Num a) => Plane3 a -> Mat3 a+defaultOrientationPlane3 (Plane3 (Vec4 a b c _)) = Mat3 $ Vec3+	(Vec3 (a) (-b) ( b*c - a*c))+	(Vec3 (b) ( a) (-a*c - b*c))+	(Vec3 (c) ( c) ( a*a + b*b))++-- | Given a plane, how far is a point from it in absolute value?+--+-- Returns negative if the point is behind the plane (e.g. you need to multiply+-- a negative number by the plane's normal to get from a point on the plane to+-- that point).+--+-- This can be done by projecting the point onto the plane's unit normal+-- (normalness is assumed and not verified here - verification would be a lot+-- easier with dependent types), and then finding projection length minus plane+-- distance.+--+-- This can also be used to detect whether a point is on front of, on, or+-- behind a plane, by checking its sign.+plane3PointDistance :: forall a. (Num a) => Plane3 a -> Vec3 a -> a+plane3PointDistance p v = projectionLength - (p^.dp3)+	where+		projectionLength = v `d3` (p^.abcp3)++-- | Get the point on the plane closest to the point in 3D space.+--+-- Project onto the unit normal (unit-lengthedness assumed and unverified),+-- find the change in distance from the plane to the point, and subtract a+-- scaled normal based on this from the original point.+pointToPlane :: forall a. (Num a) => Vec3 a -> Plane3 a -> Vec3 a+pointToPlane v p = v `minusv3` (plane3PointDistance p v `sv3` (p^.abcp3))++-- | Reflect a point about a plane.+plane3ReflectPoint :: forall a. (Num a) => Plane3 a -> Vec3 a -> Vec3 a+plane3ReflectPoint p v = plane3ReflectPointAmount p v 1++-- | Reflect a point about a plane by a certain amount.+plane3ReflectPointAmount :: forall a. (Num a) => Plane3 a -> Vec3 a -> a -> Vec3 a+plane3ReflectPointAmount p v a = v `pv3` ((1 + a) `sv3` (pointToPlane v p `minusv3` v))++-- | Construct a plane from an arbitrary point on that plane and a normal.+--+-- The unit-lengthedness of the provided normal is assumed and not verified.+normalizePlane3 :: forall a. (Num a) => Vec3 a -> Vec3 a -> Plane3 a+normalizePlane3 v abc = normalPlane3 abc d+	where+		d :: a+		d = v `d3` abc++-- | Keep the plane representing the same points, but negate the+-- direction of the normal.+negatePlaneOrientation :: forall a. (Num a) => Plane3 a -> Plane3 a+negatePlaneOrientation =+	(abcp3 %~ negate) .+	(dp3   %~ negate) .+	id++-- | A line segment or infinite line in 3D space.+--+-- A line segment can be represented by its 2 endpoints, as arbitrary points in+-- 3D space each relevant to the origin.  In this representation, we use the+-- names ‘p0’ and ‘p1’.+--+-- An infinite line in 3D can also be represented by a scaled normal vector,+-- like a plane representation, paired with an axis for the line.  This+-- representation can also be used to construct a matrix with 2 columns, the+-- final column being the homogoneous displacement to an arbitrary point on the+-- line, to represent the line.  This representation furthermore can be+-- ‘normalized’ by adjusting the displacement second column so that it points+-- to the closest point on that line, ensuring that the columns are orthogonal.+-- This normalized offset+axis representation gives you the convenient ability+-- to find the distance of the infinite line to the origin, by simply taking+-- the r3 (vector length) of the normalized displacement vector (2nd col),+-- ignoring the final extra ‘1’ coord if using homogenous coords consistently.+-- Additionally this lets you represent points on that line with a single+-- Double, by projecting it onto that plane by letting multiplying the Double+-- with the axis, and then adding the displacement vector to get onto the line.+--+-- In the axes representation, we use the names ‘o’ and ‘a0’.  If ‘o’ is+-- normalized and orthogonal to ‘a0’ (and is thus the closest point of the line+-- to the origin), we may also use the name ‘n’.  (Note: it is a _scaled_+-- normal in this case, not necessarily of unit length.)+--+-- Finally, another alternative way to represent a line _segment_ is similar+-- to the infinite line projection representation just described, except the+-- displacement is taken to be p0, the first point, and the axis is taken to be+-- p1-p0: 1*axis gets you from p0 to p1.  In this case, normalization is not+-- expected.+data Line3 a = Line3 {+	_p0l3 :: Vec3 a,+	_p1l3 :: Vec3 a+}+	deriving (Eq, Ord, Show)+makeLenses ''Line3++-- | Construct a line from 2 points.+line3Points :: Vec3 a -> Vec3 a -> Line3 a+line3Points p0 p1 = Line3 p0 p1++-- | Construct a line from a displacement vector and axis vector.+--+-- The vector doesn't have to be orthogonal to the axis like a normal.+--+-- ‘o’ could also be named ‘p0’.+line3Axes :: forall a. (Num a) => Vec3 a -> Vec3 a -> Line3 a+line3Axes o a0 = Line3 o (o `pv3` a0)++-- | Access a line's displacement vector while preserving its axis.+ol3 :: forall a. (Num a) => Lens' (Line3 a) (Vec3 a)+ol3 = lens getter (flip setter)+	where+		getter :: Line3 a -> Vec3 a+		getter (Line3 p0 _p1) = p0+		setter :: Vec3 a -> Line3 a -> Line3 a+		setter n (Line3 p0 p1) = Line3 n (n `pv3` (p1 `minusv3` p0))++-- | The first axis after the normal/displacement vector for this line.+a0l3 :: forall a. (Num a) => Lens' (Line3 a) (Vec3 a)+a0l3 = lens getter (flip setter)+	where+		getter :: Line3 a -> Vec3 a+		getter (Line3 p0 p1) = p1 `minusv3` p0+		setter :: Vec3 a -> Line3 a -> Line3 a+		setter a0 (Line3 p0 _) = Line3 p0 $ p0 `pv3` a0++-- | Normalize a line's p0/n to be the closest point to the origin.+--+-- a0 is preserved; it is not also normalized by this.+--+-- This is done by the formula:+-- 	n = o - a0*(o dot a0)/(|a0|^2)+-- Meaning original displacement vector minus its projection onto the unit ‘a0’+-- axis vector.+-- Note:+-- 	s = (-o dot v)/(|v|^2)+line3NormalizeDisplacement :: forall a. (Num a, Fractional a, RealFloat a) => Line3 a -> Line3 a+line3NormalizeDisplacement l = l & ol3 %~ subtract ((((l^.ol3) `d3` (l^.a0l3))/(sq_ (l^.a0l3.r3))) `sv3` (l^.a0l3))+	where sq_ x = x*x++-- | Find the distance from the origin to an infinite line.+line3DistanceFromOrigin :: forall a. (Num a, Fractional a, RealFloat a) => Line3 a -> a+line3DistanceFromOrigin l = (line3NormalizeDisplacement l)^.ol3.r3++-- | Given a line segment representation by its 2 endpoints, find its distance+-- to the plane in absolute value.  (Negative if closest is behind the plane.)+-- The result is 0 if it intersects the plane.+--+-- (An infinite line in 3D can also be represented by a scaled normal vector,+-- like a plane representation, paired with an axis for the line.  This+-- representation can also be used to construct a matrix with 2 columns, the+-- final column being the homogoneous displacement to an arbitrary point on the+-- line, to represent the line.  This representation furthermore can be+-- ‘normalized’ by adjusting the displacement second column so that it points+-- to the closest point on that line, ensuring that the columns are orthogonal.+-- This normalized offset+axis representation gives you the convenient ability+-- to find the distance of the infinite line to the origin, by simply taking+-- the r3 (vector length) of the normalized displacement vector (2nd col),+-- ignoring the final extra ‘1’ coord if using homogenous coords consistently.+-- Additionally this lets you represent points on that line with a single+-- Double, by projecting it onto that plane by letting multiplying the Double+-- with the axis, and then adding the displacement vector to get onto the line.)+--+-- (Finally, another alternative way to represent a line _segment_ is similar+-- to the infinite line projection representation just described, except the+-- displacement is taken to be p0, the first point, and the axis is taken to be+-- p1-p0: 1*axis gets you from p0 to p1.  In this case, normalization is not+-- expected.)+plane3LineSegmentDistance :: forall a. (Num a, Fractional a, RealFloat a) => Plane3 a -> Line3 a -> a+plane3LineSegmentDistance p l+	| p0d >= 0 && p1d >= 0 = min p0d p1d+	| p0d <= 0 && p1d <= 0 = max p0d p1d+	| otherwise            = 0+	where+		p0d = plane3PointDistance p (l^.p0l3)+		p1d = plane3PointDistance p (l^.p1l3)++-- | Reflect a line's axis about the plane with the given normal and+-- intersecting ‘o’ (‘p0’).+--+-- This can be done by finding the vector from a0 to the closest point on the+-- plane, and adding double that vector.+line3AxisReflectPlane3 :: forall a. (Num a) => Line3 a -> Vec3 a -> Line3 a+--line3AxisReflectPlane3 l abc = l & p1l3 %~ plane3ReflectPoint (normalizePlane3 (l^.ol3) abc)  -- (Alternative.)+line3AxisReflectPlane3 l abc = l & a0l3 %~ plane3ReflectPoint (normalizePlane3 zv3 abc)++-- | Project a 1D coord x onto a line, like a lerp.+--+-- The coord 0 corresponds to p0, and the coord 1 corresponds to p1.  0.5 is+-- half-way in between, and 2 is p0 + 2*(p1 - p0), i.e. p0 + 2*a0.+line3Lerp :: forall a. (Num a) => Line3 a -> a -> Vec3 a+line3Lerp l x = (l^.ol3) `pv3` (x `sv3` (l^.a0l3))++-- | 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+-- (like a lerp).  However return Nothing, if the line is parallel and+-- thus every point is the same distance.+--+-- Conveniently, the change in distance from the plane per change in x is+-- constant.+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+	| otherwise                 = Just $ (d - p0d)/dd_dx+	where+		-- Going from p0 to p1 (i.e. for every change in x by +1), how much+		-- does the distance from the plane change?+		dd_dx :: a+		dd_dx = p1d - p0d++		p0d = plane3PointDistance p (l^.p0l3)+		p1d = plane3PointDistance p (l^.p1l3)++-- | Find the coord on the line to the closest point on that line to the given+-- point in 3D space.+--+-- You can use the result with 'line3Lerp' to obtain the point in 3D space.+--+-- By projecting the arbitrary point onto the line's unit axis, we find the+-- length along the axis to the closest point, and then divide by the length of+-- the line's axis to obtain the coord.+--+-- Non-zeroness of the line's axis is assumed and not verified.+line3PointCoord :: forall a. (Num a, Fractional a, RealFloat a) => Line3 a -> Vec3 a -> a+line3PointCoord l v = v' `d3` (l^.a0l3) / sqx (l^.a0l3.r3)+	where+		v' = v `minusv3` (l^.ol3)++-- | Find the distance from the line (by the closest point on the line) to the+-- given point in space.+line3PointDistance :: forall a. (Num a, Fractional a, RealFloat a) => Line3 a -> Vec3 a -> a+line3PointDistance l v = (v - line3Lerp l (line3PointCoord l v))^.r3++-- | Relative to the closest point on the line, find what coord on the line+-- represents the point on the line exactly 'distance' distance away from the+-- point.  You can negate the coord offset and still be at the same distance.+--+-- Use this to find where on a line you would be at a given distance from the+-- provided point.  Add it to 'line3PointCoord' to find the net coord.+--+-- It works by applying the Pythagorean theorem to the triangle with hypotenuse+-- distance from 'v' to the point on the line at a distance, and with sides+-- ‘distance of point to line’ and ‘distance along the line to the desired+-- point’, finally scaling according to the line axis length so the coord is+-- correct.+--+-- Note that if the point is further from the line than the given distance,+-- your Haskell implementation may return NaN as it tries to take the sqrt of a+-- negative number.+line3DistanceCoordFromPoint :: forall a. (Num a, Fractional a, RealFloat a) => Line3 a -> Vec3 a -> a -> a+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.+--+-- (Paralleling the order, the first coord is on the first line, and the second+-- coord is on the second line.)+--+-- If they are parallel, return Nothing, indicating any pair of points on the+-- lines has an equal distance.+--+-- Find the unique pair of points on the lines such that the line segment+-- between them is orthogonal to both lines or else where the points are equal+-- (i.e. the lines intersect).+--+-- To see how this can be implemented, first we can find the direction of the+-- line segment with p0 as the closest point on the first line and p1 as the+-- closest point on the second line, after assuming for now the lines don't+-- intersect.  We can use the pattern in defaultOrientationPlane3 here, which+-- here is essentially the cross product of the 2 line axes.  This new axis+-- will be the direction of this ‘closest’ line segment ‘lc’, but we don't yet+-- know its scale (and could be negative), or the ‘ol3’ of it: where to+-- position its start.+--+-- If we pick an arbitrary point on line ‘la’, which may as well be ‘ol3’, and+-- then try applying the tentative ‘closest’ ‘lc’ line segment axis found by+-- cross product, we'll probably find it doesn't point to a point on ‘lb’, but+-- sticks out somewhere else.  We need to find the right ‘ol3’ to translate+-- this ‘lc’ axis (as well as the length of the axis).  Conveniently, the+-- closest distance from the end of this tentative ‘lc’ ‘stick’ to ‘lb’ changes+-- at a constant proportion as ‘ax’ changes.  So we just need to use this+-- change, 'ddist/dax', to find how much we need to adjust our initial guess at+-- ‘la^.ol3’ to get to connect on the second line.  This lets us find ‘ax’.+--+-- To help visualize finding ‘ddist/dax’, consider projecting onto a plane by+-- looking down the axis we found.  If we assume the length of the ‘lc’ is+-- correct, then we can look at the axes of the 2 lines, intersecting the+-- origin, in 2D space, in this projection.  As we move along ‘la’, we can look+-- at the distance from our location to (via the ‘stick’ which we can now+-- ignore) ‘lb’.  If ‘la’ is pointing right, and ‘lb’ is pointing upright at a+-- slant, then we can just advance on ‘la’ by 1, where ax=1 and the 2D coord is+-- (1, 0), and simply look at distance of our location from ‘lb’ (the closest+-- point).  Since the distance was 0 at ax=0, this distance at ax=1 will be+-- ‘ddist/dax’.  (Take the normal of ‘lb’, dot product projection on the unit+-- normal, and find distance from origin to get the distance, or just use+-- 'line3PointDistance'.)+--+-- Possibly there are more efficient ways to do this.+line3Line3ClosestCoords :: forall a. (Show a, SmallNum a, Fractional a, RealFloat a) => Line3 a -> Line3 a -> Maybe (a, a)+line3Line3ClosestCoords la lb+	| ddist_dax `equivalentSmall` 0 = Nothing+	| otherwise                     = Just (ax, bx)+	where+		-- | The axis of the tentative ‘stick’ coming from ‘la’ to likely not a+		-- point on ‘lb’, but still has the right direction (possibly negated)+		-- of the line going from the closest point on ‘la’ to the closest+		-- point on ‘lb’.+		lca0 :: Vec3 a+		lca0 = (la^.a0l3) `vx3` (lb^.a0l3)+		-- | The ‘stick’.+		_lc :: Line3 a+		_lc = line3Axes (la^.p0l3) lca0++		-- | Find vector orthogonal to ‘lc’ and ‘lb’'s axis.  This lets us+		-- project the ‘stick’'s end-point (p1) coming from ‘la’ to get the+		-- distance if the ‘stick’ had the right scale/magnitude, i.e. if ‘lc’+		-- had the right magnitude.  We can find the point on ‘lb’ closest to+		-- the the stick's end-point (lc^.p1), and project onto this+		-- lbProjectionNormal with the dot product to find the distance we're+		-- looking for.  We'll project the vector going from closest point to+		-- the stick's end-point, onto lbProjectionNormal, producing the+		-- distance.+		lbProjectionNormal = v3normalize $ lca0 `vx3` (lb^.a0l3)++		-- | For a given ax, find the distance from adding ‘lc’ at the correct+		-- scale to the closest point on ‘lb’, using lbProjectionNormal.+		distanceAtAx ax_ = theDistance+			where+				stickEndPoint = line3Lerp la ax_ + lca0+				closestLbPointToEndPoint = line3Lerp lb . line3PointCoord lb $ stickEndPoint  -- (stickendpoint is orthogonal, so both stickEndPoint and correctedStickEndPoint would yield equivalent results.)+				correctedStickEndPoint = correctedStickEndPointDistance `sv3` lbProjectionNormal+				correctedStickEndPointDistance = (stickEndPoint - closestLbPointToEndPoint) `d3` lbProjectionNormal++				theDistance = correctedStickEndPointDistance+				_theDistanceAlternative = line3PointDistance lb $ correctedStickEndPoint++		ddist_dax :: a+		ddist_dax = distanceAtAx 1 - distanceAtAx 0++		-- | f(0) = c && f'(x) = constant_of_f' ddist_dax => f(-f(0)/f'(0)) = 0+		ax = -distanceAtAx 0 / ddist_dax++		bx = line3PointCoord lb $ line3Lerp la ax++-- | Find the (closest) distance between 2 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+	Just    (ax, bx) -> (line3Lerp lb bx - line3Lerp la ax)^.r3++-- The orientation is checked, for these functions.++eqPlane3 :: (SmallNum a, Ord a, Num a, RealFloat a) => Plane3 a -> Plane3 a -> Bool+eqPlane3 a b = (a^.unPlane3) `eq4` (b^.unPlane3)++eqLine3 :: (SmallNum a, Ord a, Num a, RealFloat a) => Line3 a -> Line3 a -> Bool+eqLine3 a b = (a^.p0l3) `eq3` (b^.p0l3) && (a^.p1l3) `eq3` (b^.p1l3)++nearPlane3 :: (SmallishNum a, Ord a, Num a, RealFloat a) => Plane3 a -> Plane3 a -> Bool+nearPlane3 a b = (a^.unPlane3) `near4` (b^.unPlane3)++nearLine3 :: (SmallishNum a, Ord a, Num a, RealFloat a) => Line3 a -> Line3 a -> Bool+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.++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)++eqLine3PointsOnly :: (SmallNum a, Ord a, Num a, RealFloat a) => Line3 a -> Line3 a -> Bool+eqLine3PointsOnly a b = let na' = na & (a0l3 %~ negate) in ( (na^.p0l3) `eq3` (nb^.p0l3) && (na^.p1l3) `eq3` (nb^.p1l3) ) || ( (na'^.p0l3) `eq3` (nb^.p0l3) && (na'^.p1l3) `eq3` (nb^.p1l3) )+	where (na, nb) = let standardize = (a0l3 %~ v3normalize) . line3NormalizeDisplacement in (standardize a, standardize b)++nearPlane3PointsOnly :: (SmallishNum a, Ord a, Num a, RealFloat a) => Plane3 a -> Plane3 a -> Bool+nearPlane3PointsOnly a b = let a' = negatePlaneOrientation a in (a^.unPlane3) `near4` (b^.unPlane3) || (a'^.unPlane3) `near4` (b^.unPlane3)++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)++-- | The curve represented by p = 1/2 (x^2) a2 + x a1 + a0+-- (The 1/2 comes from integrating twice.)+data QCurve3 a = QCurve3 {+	_a2q3 :: Vec3 a,  -- ^ Acceleration.+	_a1q3 :: Vec3 a,  -- ^ Velocity (linear).+	_a0q3 :: Vec3 a   -- ^ Position (starting position at x=0).+}+	deriving (Eq, Ord, Show)+makeLenses ''QCurve3++-- | Make a quadratic curve by an acceleration vector, a velocity vector, and a+-- starting position.+qcurve3 :: Vec3 a -> Vec3 a -> Vec3 a -> QCurve3 a+qcurve3 a2 a1 a0 = QCurve3 a2 a1 a0++-- | Make a quadratic curve by an acceleration vector and a line.+qcurvePath3 :: forall a. (Num a) => Vec3 a -> Line3 a -> QCurve3 a+qcurvePath3 a2 path = QCurve3 a2 (path^.a0l3) (path^.ol3)++-- | A lens of QCurve3 for the path: the velocity and position as a path line,+-- ignoring the acceleration component.+pathq3 :: forall a. (Num a) => Lens' (QCurve3 a) (Line3 a)+pathq3 = lens getter (flip setter)+	where+		getter :: QCurve3 a -> Line3 a+		getter (QCurve3 _ a1 a0) = line3Axes a0 a1+		setter :: Line3 a -> QCurve3 a -> QCurve3 a+		setter path (QCurve3 a2 _ _) = QCurve3 a2 (path^.a0l3) (path^.ol3)++-- | Convert a coordinate on the curve to a point:+-- p = 1/2 (x^2) a2 + x a1 + a0+qcurve3Qerp :: forall a. (Num a, Fractional a) => QCurve3 a -> a -> Vec3 a+qcurve3Qerp q x = ((1/2) * (sqx x)) `sv3` (q^.a2q3) + x `sv3` (q^.a1q3) + (q^.a0q3)++-- | Find the velocity at a coord.+-- v = x a2 + a1+qcurve3Vel :: forall a. (Num a) => QCurve3 a -> a -> Vec3 a+qcurve3Vel q x = x `sv3` (q^.a2q3) + (q^.a1q3)++-- | Find the acceleration at a coord.+-- v = a2+qcurve3Accel :: forall a. (Num a) => QCurve3 a -> a -> Vec3 a+qcurve3Accel q _x = (q^.a2q3)
+ Immutaball/Share/SDLManager.hs view
@@ -0,0 +1,274 @@+{-# 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 #-}++-- State.hs.++{-# LANGUAGE Haskell2010 #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Some SDL functions that some functions can only be called in the OS thread+-- that set up video.+--+-- So I created a module that video setup and input event callers can route+-- their requests through, to ensure they are called from the same OS thread to+-- meet this requirement mentioned in the documentation.+--+-- Example:+-- > pollEvent :: MonadIO m => m (Maybe Event)+-- >+-- > Poll for currently pending events. You can only call this function in the OS thread that set the video mode.+module Immutaball.Share.SDLManager+	(+		-- * High level+		withSDLManager,+		withSDLManager',+		SDLManagerHandle(..), sdlmh_done, sdlmh_doneReceived, sdlmh_commands,+		SDLManagerCommand(..),+		issueSDLCommand,++		-- * Utils+		sdlGLSwapWindow,+		sdlGL,+		sdlGL1,+		sdlGLHomogeneous,+		sdlGL_,+		sdl,+		attachLifetime,+		sdlIBIO,++		-- * Low level+		initSDLManager,+		quitSDLManager,+		sdlManagerFreeResources,+		sdlManagerThread,+		sdlManagerThreadContinue+	) where++import Prelude ()+import Immutaball.Prelude++import Data.Functor++import Control.Concurrent.STM.TMVar+import Control.Concurrent.STM.TVar+import Control.Concurrent.STM.TChan+import Control.Lens+import Control.Monad.STM+import qualified SDL.Init+import qualified SDL.Video++import Immutaball.Share.ImmutaballIO+import Immutaball.Share.ImmutaballIO.BasicIO+import Immutaball.Share.ImmutaballIO.GLIO+import Immutaball.Share.ImmutaballIO.SDLIO+import Immutaball.Share.SDLManager.Types+import Immutaball.Share.Utils++-- * High level++-- | Create an SDL manager and manage its lifetime.+withSDLManager :: (SDLManagerHandle -> ImmutaballIO) -> ImmutaballIO+withSDLManager = withSDLManager' False++-- | Adds a headless setting.+withSDLManager' :: Bool -> (SDLManagerHandle -> ImmutaballIO) -> ImmutaballIO+withSDLManager' headless withHandle =+	initSDLManager headless $ \sdlManagerHandle ->+	withHandle sdlManagerHandle <>>+	quitSDLManager sdlManagerHandle++-- Moved to .Types to fix Template Haskell erors:+-- SDLManagerHandle+-- SDLManagerCommand++issueSDLCommand :: SDLManagerHandle -> SDLManagerCommand -> me -> ImmutaballIOF me+issueSDLCommand sdlMgr cmd withUnit = Atomically (writeTChan (sdlMgr^.sdlmh_commands) cmd) (\() -> withUnit)++-- * Utils++-- | Swap the window, but also wait for the swap to finish.+sdlGLSwapWindow :: SDLManagerHandle -> SDL.Video.Window -> me -> ImmutaballIOF me+sdlGLSwapWindow sdlMgr window withUnit =+	JoinIBIOF . JoinIBIOF .+	Atomically (newEmptyTMVar) $ \mdone ->+	issueSDLCommand sdlMgr (GLSwapWindow window mdone) $+	Atomically (takeTMVar mdone) $ \() ->+	withUnit++-- | Run an ordered GLIO sequence in the SDL manager thread.+--+-- This might be needed to avoid issues with multi-threaded SDL & OpenGL on+-- some platforms.+sdlGL :: SDLManagerHandle -> [GLIOFTo] -> ImmutaballIOF ()+sdlGL sdlMgr glioTos =+	JoinIBIOF . JoinIBIOF .+	Atomically (newEmptyTMVar) $ \hasDone ->+	issueSDLCommand sdlMgr (GLSequence glioTos hasDone) $+	Atomically (takeTMVar hasDone) id++-- | 'sdlGL' variant specialized to a single GLIO.+sdlGL1 :: SDLManagerHandle -> GLIOF me -> ImmutaballIOF me+sdlGL1 sdlMgr glio = unSingleton <$> sdlGLHomogeneous sdlMgr [glio]+	where+		unSingleton [me] = me+		unSingleton _    = error "Internal error: sdlGL1 expected a single result."++-- | Run an ordered GLIO sequence in the SDL manager thread.+--+-- This might be needed to avoid issues with multi-threaded SDL & OpenGL on+-- some platforms.+--+-- This version handles reading the results but only supports it when the types+-- are all the same.+sdlGLHomogeneous :: forall me. SDLManagerHandle -> [GLIOF me] -> ImmutaballIOF [me]+sdlGLHomogeneous sdlMgr glios = foldr reduce reduction0 glios []+	where+		reduce :: GLIOF me -> ([(GLIOF me, TMVar me)] -> ImmutaballIOF [me]) -> ([(GLIOF me, TMVar me)] -> ImmutaballIOF [me])+		reduce glio withGlioTos = \glioTos -> JoinIBIOF . Atomically (newEmptyTMVar) $ \to_ -> withGlioTos ((glio, to_):glioTos)+		reduction0 :: [(GLIOF me, TMVar me)] -> ImmutaballIOF [me]+		reduction0 reversedGlioTos =+			let glioTos  = reverse reversedGlioTos in+			let glioTos' = map GLIOFTo $ glioTos in+			let tos      = map snd glioTos in+			JoinIBIOF . JoinIBIOF .+			Atomically (newEmptyTMVar) $ \hasDone ->+			issueSDLCommand sdlMgr (GLSequence glioTos' hasDone) .+			JoinIBIOF .+			Atomically (takeTMVar hasDone) $ \() ->+			foldr readReduce readReduction0 $ tos++		readReduce :: TMVar me -> ImmutaballIOF [me] -> ImmutaballIOF [me]+		readReduce to_ then_ =+			JoinIBIOF . Atomically (takeTMVar to_) $ \me -> (me:) <$> then_+		readReduction0 :: ImmutaballIOF [me]+		readReduction0 = PureIBIOF []++-- | An 'sdlGL' variant that only handles valueless sequences.+--+-- Additionally it only waits for the signal that all are done.  (The caller+-- can fork off a GL call if desired while it does other things in the+-- background; only the SDL thread would be blocked here.)+sdlGL_ :: SDLManagerHandle -> [GLIOF ()] -> ImmutaballIOF ()+sdlGL_ sdlMgr glios =+	JoinIBIOF . JoinIBIOF .+	Atomically (newEmptyTMVar) $ \hasDone ->+	issueSDLCommand sdlMgr (GLSequenceValueless glios hasDone) $+	Atomically (takeTMVar hasDone) id++-- | Run an general SDL command in the SDL Manager thread.+sdl :: SDLManagerHandle -> SDLIOF me -> ImmutaballIOF me+sdl sdlMgr sdlio =+	JoinIBIOF . JoinIBIOF .+	Atomically (newEmptyTMVar) $ \to_ ->+	issueSDLCommand sdlMgr (GenSDL sdlio to_) $+	Atomically (takeTMVar to_) id++-- | Attach a resource to the lifetime of the SDL Manager thread.+attachLifetime :: SDLManagerHandle -> ImmutaballIOF resource -> (resource -> ImmutaballIOF ()) -> TMVar resource -> me -> ImmutaballIOF me+attachLifetime sdlMgr init_ free to_ withUnit = issueSDLCommand sdlMgr (AttachLifetime (ResourceAllocationTo ((init_, free), to_))) withUnit++-- | Run an general ImmutaballIOF command in the SDL Manager thread.+--+-- Note that the command blocks the SDL Manager thread when it handles it; you+-- can fork if this is not desired.+sdlIBIO :: SDLManagerHandle -> ImmutaballIOF me -> ImmutaballIOF me+sdlIBIO sdlMgr ibio =+	JoinIBIOF . JoinIBIOF .+	Atomically (newEmptyTMVar) $ \to_ ->+	issueSDLCommand sdlMgr (GenIBIO ibio to_) $+	Atomically (takeTMVar to_) id++-- * Low level++-- | Manually start the lifetime of the SDLManager OS thread; the caller will+-- need to manage the lifetime.+initSDLManager :: Bool -> (SDLManagerHandle -> ImmutaballIO) -> ImmutaballIO+initSDLManager headless withSdlMgr =+	mkAtomically (newTVar False) $ \done ->+	mkAtomically (newTVar False) $ \doneReceived ->+	mkAtomically newTChan $ \commands ->+	mkAtomically (newTVar []) $ \finalizers ->+	let sdlMgr = SDLManagerHandle {+		_sdlmh_done         = done,+		_sdlmh_doneReceived = doneReceived,+		_sdlmh_commands     = commands,+		_sdlmh_finalizers   = finalizers+	}+	in mkBIO . ForkOS (sdlManagerThread headless sdlMgr) $ withSdlMgr sdlMgr++-- | Manually close the SDLManager thread low-level.  High-level+-- 'withSDLManager' automatically manages the lifetime.+quitSDLManager :: SDLManagerHandle -> ImmutaballIO+quitSDLManager sdlMgr =+	sdlManagerFreeResources sdlMgr $+	mkAtomically (do+		writeTVar (sdlMgr^.sdlmh_done) True) (const mempty) <>+	mkAtomically (do+		writeTChan (sdlMgr^.sdlmh_commands) QuitSDLManager) (const mempty) <>>+	mkAtomically (do+		readTVar (sdlMgr^.sdlmh_doneReceived) >>= check) (const mempty)++sdlManagerFreeResources :: SDLManagerHandle -> ImmutaballIO -> ImmutaballIO+sdlManagerFreeResources sdlMgr then_ =+	-- Take the first finalizer.+	mkAtomically (do+		finalizers <- readTVar (sdlMgr^.sdlmh_finalizers)+		let (mfinalizer, finalizers') = case finalizers of+			[]               -> (Nothing, [])+			(finalizer:rest) -> (Just finalizer, rest)+		writeTVar (sdlMgr^.sdlmh_finalizers) finalizers'+		return mfinalizer+	) $ \mfinalizer ->+	-- Run it, if the resource is still there.+	case mfinalizer of+		Nothing        -> then_+		Just _finalizer@(ResourceAllocationTo ((_init, free), to_)) ->+			mkAtomically (tryTakeTMVar to_) $ \mresource ->+			case mresource of+				Nothing       -> then_+				Just resource ->+					Fixed $ free resource >>= \() -> getFixed $ sdlManagerFreeResources sdlMgr then_++-- | The thread with initialization.+sdlManagerThread :: Bool -> SDLManagerHandle -> ImmutaballIO+sdlManagerThread headless sdlMgr =+	let initFlags = if' headless [] [SDL.Init.InitVideo, SDL.Init.InitAudio] ++ [SDL.Init.InitJoystick] in+	mkBIO . SDLIO . SDLWithInit initFlags .+	mkBIO . SDLIO . SDLWithTTFInit $+	sdlManagerThreadContinue sdlMgr++-- | The thread after initialization.+sdlManagerThreadContinue :: SDLManagerHandle -> ImmutaballIO+sdlManagerThreadContinue sdlMgr =+	mkAtomically (+		readTVar (sdlMgr^.sdlmh_done) >>= \done ->+		(check done $> Left done) `orElse` (Right <$> readTChan (sdlMgr^.sdlmh_commands))+	) $ \doneOrCmd ->+	case doneOrCmd of+		Left done -> if not done then sdlManagerThreadContinue sdlMgr else quit+		Right cmd -> case cmd of+			QuitSDLManager -> quit+			NopSDLManager -> sdlManagerThreadContinue sdlMgr+			PollEvent to_ -> (mkBIO . SDLIO . SDLPollEventSync $ \mevent -> mkAtomically (writeTMVar to_ mevent) (\() -> mempty)) <>> sdlManagerThreadContinue sdlMgr+			PollEvents to_ -> (mkBIO . SDLIO . SDLPollEventsSync $ \events -> mkAtomically (writeTMVar to_ events) (\() -> mempty)) <>> sdlManagerThreadContinue sdlMgr+			WithWindow title cfg      to_ -> mkBIO . SDLIO . SDLWithWindow title cfg $   \window -> mkAtomically (writeTMVar to_ window) $ \() -> sdlManagerThreadContinue sdlMgr+			WithGLContext window      to_ -> mkBIO . SDLIO . SDLWithGLContext window $   \cxt    -> mkAtomically (writeTMVar to_ cxt)    $ \() -> sdlManagerThreadContinue sdlMgr+			GLSwapWindow window       to_ -> mkBIO . SDLIO . SDLGLSwapWindow window  $              mkAtomically (writeTMVar to_ ())     $ \() -> sdlManagerThreadContinue sdlMgr+			--GLSequence glios          tos -> Fixed $ (BasicIBIOF $ GLIO glio)        >>= \me     ->   Atomically (writeTMVar to_ me)     $ \() -> sdlManagerThreadContinue sdlMgr+			--GLSequence glios          tos -> Fixed $ foldr (\(glio, to_) then_ -> (BasicIBIOF . GLIO $ glio) >>= \me -> Atomically (writeTMVar to_ me) $ \() -> Fixed then_) (getFixed $ sdlManagerThreadContinue sdlMgr) (zip glios tos)+			GLSequence glioTos   hasDone_ -> Fixed $ foldr (\(GLIOFTo (glio, to_)) then_ -> (BasicIBIOF . GLIO $ glio) >>= \me -> Atomically (writeTMVar to_ me) $ \() -> Fixed then_) (Atomically (writeTMVar hasDone_ ()) $ \() -> sdlManagerThreadContinue sdlMgr) glioTos+			AttachLifetime a@(ResourceAllocationTo ((init_, _free), to_)) ->+				if waitForResourceInitializers+					then+						Fixed $ Atomically (modifyTVar (sdlMgr^.sdlmh_finalizers) (a:)) id >>= \() -> init_ >>= \resource -> Atomically (writeTMVar to_ resource) id >>= \() -> getFixed $ sdlManagerThreadContinue sdlMgr+					else+						Fixed $ Atomically (modifyTVar (sdlMgr^.sdlmh_finalizers) (a:)) id >>= \() -> forkBoundIBIOF (init_ >>= \resource -> Atomically (writeTMVar to_ resource) id >>= \() -> mempty) . getFixed $ sdlManagerThreadContinue sdlMgr+			GLSequenceValueless glios to_ -> Fixed $ foldr (\glio then_ -> (BasicIBIOF . GLIO $ glio) >>= \() -> then_) (Atomically (writeTMVar to_ ()) $ \() -> sdlManagerThreadContinue sdlMgr) glios+			GenSDL sdlio              to_ -> Fixed $ (BasicIBIOF . SDLIO $ sdlio) >>= \me -> Atomically (writeTMVar to_ me) $ \() -> sdlManagerThreadContinue sdlMgr+			GenIBIO ibio              to_ -> Fixed $ ibio >>= \me -> Atomically (writeTMVar to_ me) $ \() -> sdlManagerThreadContinue sdlMgr+	where+		quit :: ImmutaballIO+		quit = mkAtomically (writeTVar (sdlMgr^.sdlmh_doneReceived) True) mempty <>> mkAtomically (writeTVar (sdlMgr^.sdlmh_done) True) mempty <>> mempty+		waitForResourceInitializers :: Bool+		waitForResourceInitializers = False
+ Immutaball/Share/SDLManager/Config.hs view
@@ -0,0 +1,28 @@+{-# 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 #-}++-- State.hs.++{-# LANGUAGE Haskell2010 #-}+{-# LANGUAGE TemplateHaskell #-}++module Immutaball.Share.SDLManager.Config+	(+		SDLManagerStaticConfig(..),+		defaultSDLManagerStaticConfig+	) where++import Prelude ()+--import Immutaball.Prelude++import Control.Lens++data SDLManagerStaticConfig = SDLManagerStaticConfig {+}+makeLenses ''SDLManagerStaticConfig++-- | Default static config.+defaultSDLManagerStaticConfig :: SDLManagerStaticConfig+defaultSDLManagerStaticConfig = SDLManagerStaticConfig {+}
+ Immutaball/Share/SDLManager/Types.hs view
@@ -0,0 +1,72 @@+{-# 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 #-}++-- State.hs.++{-# LANGUAGE Haskell2010 #-}+{-# LANGUAGE TemplateHaskell, ExistentialQuantification #-}++-- | Moved into another module to avoid Template Haskell errors.+module Immutaball.Share.SDLManager.Types+	(+		SDLManagerHandle(..), sdlmh_done, sdlmh_doneReceived, sdlmh_commands,+			sdlmh_finalizers,+		SDLManagerCommand(..),+		GLIOFTo(..),+		ResourceAllocation(..),+		ResourceAllocationTo(..)+	) where++import Prelude ()+import Immutaball.Prelude++import Control.Concurrent.STM.TMVar+import Control.Concurrent.STM.TVar+import Control.Concurrent.STM.TChan+import Control.Lens+import qualified Data.Text as T+import SDL.Event+import SDL.Video++import Immutaball.Share.ImmutaballIO+import Immutaball.Share.ImmutaballIO.GLIO+import Immutaball.Share.ImmutaballIO.SDLIO++-- Moved from later to fix Template Haskell errors.+data SDLManagerCommand =+	-- | Close the manager; it's done.+	  QuitSDLManager+	| NopSDLManager+	-- | SDL.Event.pollEvent documents that it requires it be run in the OS+	-- thread which set the video mode, which is why SDLManager solely manages+	-- this.+	| PollEvent (TMVar (Maybe Event))+	| PollEvents (TMVar ([Event]))+	| WithWindow T.Text WindowConfig (TMVar Window)+	| WithGLContext Window (TMVar GLContext)+	| GLSwapWindow Window (TMVar ())+	| GLSequence [GLIOFTo] (TMVar ())+	| GLSequenceValueless [GLIOF ()] (TMVar ())+	-- | Attach a resource to the lifetime of the SDL Manager thread.+	| AttachLifetime ResourceAllocationTo+	| forall me. GenSDL (SDLIOF me) (TMVar me)+	| forall me. GenIBIO (ImmutaballIOF me) (TMVar me)++data GLIOFTo = forall me. GLIOFTo { _gliofTo :: (GLIOF me, TMVar me) }++data ResourceAllocation = forall me. ResourceAllocation { _resourceAllocation :: (ImmutaballIOF me, me -> ImmutaballIOF ()) }+data ResourceAllocationTo = forall me. ResourceAllocationTo { _resourceAllocationTo :: ((ImmutaballIOF me, me -> ImmutaballIOF ()), TMVar me) }++-- | The inner fields and lenses are internal (low-level).+data SDLManagerHandle = SDLManagerHandle {+	_sdlmh_done :: TVar Bool,+	_sdlmh_doneReceived :: TVar Bool,+	_sdlmh_commands :: TChan SDLManagerCommand,++	-- | Stored in reverse order, which is actually convenient for us, since we+	-- can then free in reverse order of init order.+	_sdlmh_finalizers :: TVar [ResourceAllocationTo]+}+	deriving (Eq)+makeLenses ''SDLManagerHandle  -- Error for future module reference.
+ Immutaball/Share/State.hs view
@@ -0,0 +1,242 @@+{-# 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 #-}++-- State.hs.++{-# LANGUAGE Haskell2010 #-}+{-# LANGUAGE Arrows, TemplateHaskell #-}++module Immutaball.Share.State+	(+		-- * Immutaball wires+		Immutaball,+		ImmutaballA,+		ImmutaballM,+		runImmutaballM,+		RequestFrameMulti,+		RequestFrameSingle,+		RequestFrame,+		Request(..), AsRequest(..),+		ResponseFrameMulti,+		ResponseFrameSingle,+		ResponseFrame,+		Response(..), AsResponse(..),+		{-+		closeFork,+		closeFork',+		immutaballIOLinear,+		-}+		stepImmutaball,+		stepImmutaballWire,+		liftIBIO,++		IBContext,+		ContextConfig,+		StaticConfig,++		-- * Frame management+		immutaballMultiToSingle,+		immutaballSingleToMulti,+		immutaballSingleToMultiWith,+		fromImmutaballMulti,+		fromImmutaballSingle,+		fromImmutaballSingleWith,+		immutaballMultiQueueFrames,++		-- * Frame management: Simpler variants+		immutaballMultiToSingle',+		immutaballSingleToMulti',+		fromImmutaballMulti',+		fromImmutaballSingle',+		immutaballMultiQueueFrames'+	) where++import Prelude ()+import Immutaball.Prelude++import Control.Arrow+import Data.Functor.Identity++import Control.Lens++import Control.Monad.Trans.MaybeM+import Immutaball.Share.AutoPar+import Immutaball.Share.Config+import Immutaball.Share.Context+import Immutaball.Share.Context.Config+import Immutaball.Share.ImmutaballIO+import Immutaball.Share.Utils+import Immutaball.Share.Wire++-- * Immutaball wires++-- | An immutaball wire.+--+-- Wire is perhaps like Fixed StateT.+--+-- > data Wire m a b = Wire { _stepWire :: a -> m (b, Wire m a b) }+--type Immutaball = Wire Maybe RequestFrame ResponseFrame+type Immutaball = Wire ImmutaballM RequestFrame ResponseFrame++type ImmutaballA b c = Wire ImmutaballM (RequestFrame, b) (ResponseFrame, c)++-- | Immutaball wire monad.+type ImmutaballM = AutoParT (MaybeMT ImmutaballIOF)++runImmutaballM :: ImmutaballM me -> ImmutaballIOF me+runImmutaballM = runMaybeInMT . runAutoParT++type RequestFrameMulti = [Request]+type RequestFrameSingle = Identity Request+type RequestFrame = RequestFrameMulti+data Request =+	  Clock Double           -- ^ timer dt+	| Paint Double           -- ^ paint t+	| Point Int Int Int Int  -- ^ mouse movement x y dx dy+	| Stick Int Double       -- ^ stick axis value+	| Angle Double Double    -- ^ angle x z+	| Click Int Bool         -- ^ click button down+	| Keybd Int Bool         -- ^ keyboard char down+	| Buttn Int Bool         -- ^ button button down+	| Touch Int Int Double Double Double Double Double  -- ^ finger-touch device finger x y dx dy pressure+	deriving (Eq, Ord, Show)+--makeClassyPrisms ''Request++type ResponseFrameMulti = [Response]+type ResponseFrameSingle = Identity Response+type ResponseFrame = ResponseFrameMulti+data Response =+	-- | Tell the controller that we're alive and to keep stepping.+	-- If there is no continue response, this thread is done if there is no+	-- forking.  If there are multiple continue responses in a single step,+	-- this tells the controller to fork (not applicable with single reponse+	-- wires).  (On a single fork, as the controller source indicates, only use+	-- the fork construction like 'PureFork', which means this thread will+	-- still continue alongside the fork; if you include both a PureFork a+	-- ContinueResponse, the end result will be 3 steppers running, not 2+	-- steppers.)+	  ContinueResponse+	-- | Tell the controller to stop stepping.  We are done.  (In a multi+	-- frame, this is equivalent to a no-op; removing it from the response list+	-- gives equivalent results, for our controller.)+	| DoneResponse+	-- | Request the controller fork the wire; requires the context enable forking.+	| PureFork         Immutaball+	-- | Request the controller fork the wire; requires the context enable forking.+	| ImmutaballIOFork (ImmutaballIOF Immutaball)+	-- | AnythingElseToTellTheController NewIBContextIfNeeded SomeOtherData+--makeClassyPrisms ''Response++-- The controller now manages forking and closing more fully.+{-+-- | End a wire.+--+-- This can be combined with 'ImmutaballIOFork' to keep a single wire running.+{- --closeFork :: Immutaball -}+closeFork :: Wire ImmutaballMClosable () ()+--closeFork = wire $ \_ -> hoistMaybe Nothing+closeFork = withM returnA (const . hoistMaybe $ Nothing)++closeFork' :: Wire ImmutaballMClosable () a+--closeFork' = wire $ \_ -> hoistMaybe Nothing+closeFork' = withM returnA (const . hoistMaybe $ Nothing)++immutaballIOLinear :: ImmutaballIOF Immutaball -> Wire ImmutaballMClosable () ResponseFrame+immutaballIOLinear ibIO = wire (\() -> hoistMaybe $ Just ([ImmutaballIOFork ibIO], closeFork'))+-}++-- | Convenience utility to simplify the 'AutoPar' layer.+--+-- It's 'stepWire' without 'AutoPar'.+stepImmutaball :: Immutaball -> RequestFrame -> ImmutaballIOF (ResponseFrame, Immutaball)+stepImmutaball = stepImmutaballWire++-- | Convenience utility to simplify the 'AutoPar' layer.+--+-- It's 'stepWire' without 'AutoPar'.+stepImmutaballWire :: Wire ImmutaballM a b -> a -> ImmutaballIOF (b, Wire ImmutaballM a b)+stepImmutaballWire immutaball request = runImmutaballM $ stepWire immutaball request++liftIBIO :: ImmutaballIOF a -> ImmutaballM a+liftIBIO = AutoParT . MaybeMT . Left++type IBContext     = IBContext' Immutaball+type ContextConfig = ContextConfig' IBContext Immutaball+type StaticConfig  = StaticConfig' (IBContext -> Maybe Immutaball)++-- * Frame management++-- | Send one request at a time; if there is no response, then treat it as a+-- DoneResponse (just as the controller would close a wire if a multi-response+-- wire returns [] with no continue).+immutaballMultiToSingle :: Wire ImmutaballM (RequestFrameMulti, a) (ResponseFrameMulti, b) -> Wire ImmutaballM (RequestFrameSingle, a) (ResponseFrameSingle, b)+immutaballMultiToSingle w = proc (Identity request, a) -> do+	(responses, b) <- w -< ([request], a)+	mresponse <- queue -< responses+	returnA -< ((Identity $ maybe DoneResponse id mresponse), b)++-- | If the single wire received no request, we give an empty response frame+-- (like a DoneResponse).+immutaballSingleToMulti :: (Monoid b) => Wire ImmutaballM (RequestFrameSingle, a) (ResponseFrameSingle, b) -> Wire ImmutaballM (RequestFrameMulti, a) (ResponseFrameMulti, b)+immutaballSingleToMulti = immutaballSingleToMultiWith mempty++-- | If the single wire received no request, we give an empty response frame+-- (like a DoneResponse).+immutaballSingleToMultiWith :: b -> Wire ImmutaballM (RequestFrameSingle, a) (ResponseFrameSingle, b) -> Wire ImmutaballM (RequestFrameMulti, a) (ResponseFrameMulti, b)+immutaballSingleToMultiWith whenEmpty w = proc (requests, a) -> do+	request <- queue -< requests+	case request of+		Nothing -> do+			returnA -< ([], whenEmpty)+		Just jrequest -> do+			((Identity response), b) <- w -< (Identity jrequest, a)+			returnA -< ([response], b)++fromImmutaballMulti :: Wire ImmutaballM (RequestFrameMulti, a) (ResponseFrameMulti, b) -> ImmutaballA a b+fromImmutaballMulti = id++fromImmutaballSingle :: (Monoid b) => Wire ImmutaballM (RequestFrameSingle, a) (ResponseFrameSingle, b) -> ImmutaballA a b+fromImmutaballSingle = immutaballSingleToMulti++fromImmutaballSingleWith :: b -> Wire ImmutaballM (RequestFrameSingle, a) (ResponseFrameSingle, b) -> ImmutaballA a b+fromImmutaballSingleWith = immutaballSingleToMultiWith++-- | Transform a wire that can handle unlimited requests and response,+-- into one that queues up to the context's limit to only process so many+-- requests and so many responses at once.+immutaballMultiQueueFrames :: IBContext -> Wire ImmutaballM (RequestFrameMulti, a) (ResponseFrameMulti, b) -> Wire ImmutaballM (RequestFrameMulti, a) (ResponseFrameMulti, b)+immutaballMultiQueueFrames cxt w = proc (requests, a) -> do+	requestChunk <- maybe returnA queueN (cxt^.ibStaticConfig.maxStepFrameSize) -< requests+	(responses, b) <- w -< (requestChunk, a)+	responseChunk <- maybe returnA queueN (cxt^.ibStaticConfig.maxResponseFrameSize) -< responses+	returnA -< (responseChunk, b)++-- * Frame management: Simpler variants++-- | Send one request at a time; if there is no response, then treat it as a+-- DoneResponse (just as the controller would close a wire if a multi-response+-- wire returns [] with no continue).+immutaballMultiToSingle' :: Wire ImmutaballM RequestFrameMulti ResponseFrameMulti -> Wire ImmutaballM RequestFrameSingle ResponseFrameSingle+immutaballMultiToSingle' = withOpenSecondIO immutaballMultiToSingle++-- | If the single wire received no request, we give an empty response frame+-- (like a DoneResponse).+immutaballSingleToMulti' :: Wire ImmutaballM RequestFrameSingle ResponseFrameSingle -> Wire ImmutaballM RequestFrameMulti ResponseFrameMulti+immutaballSingleToMulti' = withOpenSecondIO immutaballSingleToMulti++fromImmutaballMulti' :: Wire ImmutaballM RequestFrameMulti ResponseFrameMulti -> Immutaball+fromImmutaballMulti' = id++fromImmutaballSingle' :: Wire ImmutaballM RequestFrameSingle ResponseFrameSingle -> Immutaball+fromImmutaballSingle' = immutaballSingleToMulti'++-- | Transform a wire that can handle unlimited requests and response,+-- into one that queues up to the context's limit to only process so many+-- requests and so many responses at once.+immutaballMultiQueueFrames' :: IBContext -> Wire ImmutaballM RequestFrameMulti ResponseFrameMulti -> Wire ImmutaballM RequestFrameMulti ResponseFrameMulti+immutaballMultiQueueFrames' cxt = closeSecondI . closeSecondO . immutaballMultiQueueFrames cxt . openSecondO . openSecondI++-- Lenses at end of file to avoid TH errors.+makeClassyPrisms ''Request+makeClassyPrisms ''Response
+ Immutaball/Share/State/Context.hs view
@@ -0,0 +1,1079 @@+{-# 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 #-}++-- State.hs.++{-# LANGUAGE Haskell2010 #-}+{-# LANGUAGE TemplateHaskell, Arrows, ScopedTypeVariables #-}++module Immutaball.Share.State.Context+	(+		IBStateContext(..), ibContext, ibNeverballrc, ibSDLWindow,+			ibSDLGLContext, ibSDLFont, ibShader, ibGLTextureNames,+			ibGLTextTextures, ibGLAllocatedTextures, ibSSBOs, ibElemVaoVboEbo,+			ibBallElemVaoVboEbo, ibCurrentlyLoadedSol,+		initialStateCxt,+		stateContextStorage,+		requireVideo,+		requireShader,+		requireFont,+		requireGLTextureNames,+		requireGLTextTextures,+		requireGLMtrlTextures,+		requireGLAllocatedTextures,+		requireLoadedSolStorage,+		requireMisc,+		requireBasics,+		finishFrame,+		finishFramePaint,+		checkGLErrors,+		glErrType,++		-- * Utils+		newTextureNameWithoutGenText,+		freeTextureNameWithoutGenText,+		newTextureName,+		freeTextureName,+		createTexture,+		freeTexture,++		cachingRenderText,+		uncacheText,+		clearTextCache,+		freeTextures,+		ibFreeTextures,++		uncacheMtrl,+		clearMtrlCache,+		freeAllTextures,+		ibFreeAllTextures,+		cachingRenderMtrl,++		juicyPixelsDynamicImageToJPImage,+		juicyPixelsImageToImage,++		checkPrecacheMtrls,+		precacheMtrls,+		precacheMtrlsIB,+		precacheMtrlsDirect,++		checkPrecacheMisc,+		precacheMisc,+		precacheMiscIB,+		precacheMiscDirect,++		freeSSBOs,+		freeSSBOsIB,+		freeElemVaoVboEbo,+		freeBallElemVaoVboEbo,+		freeElemVaoVboEboIB,+		freeBallElemVaoVboEboIB,+		setSSBO,+		setElemVaoVboEbo,+		setBallElemVaoVboEbo,+		getElemVaoVboEbo,+		getBallElemVaoVboEbo,++		setCurrentlyLoadedSOL,++		setTransformation+	) where++import Prelude ()+import Immutaball.Prelude++import Control.Arrow+import Control.Monad+import Data.Bits+import Data.Either+import Data.Int+import Data.List+import Data.Maybe+import Foreign.Storable+import Text.Printf++import qualified Codec.Picture as JP+import qualified Codec.Picture.Types as JP+import Control.Lens+import Control.Concurrent.STM.TMVar+import Control.Concurrent.STM.TVar+import Data.Array.IArray+import qualified Data.ByteString as BS+import qualified Data.ByteString.Builder as BB+import qualified Data.ByteString.Lazy as BL+import qualified Data.Map.Lazy as M+import qualified Data.Set as S+import qualified Data.Text as T+import Graphics.GL.Core45+import Graphics.GL.Types+import qualified SDL.Font as SDL.Font  -- (sdl2-ttf)+import SDL.Vect as SDL+import qualified SDL.Video as SDL  -- (ambiguous ‘createTexture’)+--import SDL.Video.OpenGL as SDL+import System.FilePath++import Immutaball.Share.Config+import Immutaball.Share.Context+import Immutaball.Share.Context.Config+import Immutaball.Share.ImmutaballIO+import Immutaball.Share.ImmutaballIO.BasicIO+import Immutaball.Share.ImmutaballIO.GLIO+import Immutaball.Share.ImmutaballIO.SDLIO+import Immutaball.Share.Math+import Immutaball.Share.SDLManager+import Immutaball.Share.State+import Immutaball.Share.Utils+import Immutaball.Share.Wire+import Immutaball.Share.Video++-- | A running Immutaball context instance.+--+-- Normally the controller doesn't deal with this.+data IBStateContext = IBStateContext {+	_ibContext :: IBContext,++	_ibNeverballrc :: Neverballrc,++	_ibSDLWindow :: Maybe (SDL.Window),+	_ibSDLGLContext :: Maybe (SDL.GLContext),+	_ibSDLFont :: Maybe (SDL.Font.Font),+	_ibShader :: Maybe (TMVar ImmutaballShaderHandle),++	-- | Used, freed.+	_ibGLTextureNames      :: Maybe (TVar (S.Set GLuint, S.Set GLuint)),+	_ibGLTextTextures      :: Maybe (TVar (M.Map T.Text  (WidthHeightI, GLuint))),+	_ibGLMtrlTextures      :: Maybe (TVar (M.Map String ((WidthHeightI, GLuint), MtrlMeta))),+	-- | By tracking allocated textures, we can attach their lifetimes to the+	-- SDL Manager thread to automatically clean them up upon quit.+	-- 'createTexture' and 'freeTexture' use this interface.+	_ibGLAllocatedTextures :: Maybe (TVar (S.Set GLuint, S.Set GLuint)),++	-- | A map of locations to ssbo handles.  If an SSBO with data has been+	-- uploaded, it should be in the map; the shader can access the array data /+	-- SSBO through setting the location to the same int.  Once it's freed, it+	-- should no longer be there.+	_ibSSBOs :: Maybe (TVar (M.Map GLuint GLuint)),+	-- | Scene VAO, trivial identity elem indices.+	--+	-- The VAO is like a ‘full’ array: the header/meta info and the pointer+	-- to the second part of this, which is the raw data, just the array itself.+	-- This is VAO, VBO, EBO.+	_ibElemVaoVboEbo :: Maybe (TMVar (GLuint, GLuint, GLuint)),+	-- | Ball VAO, trivial identity elem indices (i.e. array of 0, 1, 2, …).+	_ibBallElemVaoVboEbo :: Maybe (TMVar (GLuint, GLuint, GLuint)),++	_ibCurrentlyLoadedSol :: Maybe (TMVar String)+}+makeLenses ''IBStateContext++initialStateCxt :: IBContext -> IBStateContext+initialStateCxt cxt = IBStateContext {+	_ibContext = cxt,++	_ibNeverballrc = cxt^.ibNeverballrc0,++	_ibSDLWindow           = Nothing,+	_ibSDLGLContext        = Nothing,+	_ibSDLFont             = Nothing,+	_ibShader              = Nothing,+	_ibGLTextureNames      = Nothing,+	_ibGLTextTextures      = Nothing,+	_ibGLMtrlTextures      = Nothing,+	_ibGLAllocatedTextures = Nothing,+	_ibSSBOs               = Nothing,+	_ibElemVaoVboEbo       = Nothing,+	_ibBallElemVaoVboEbo   = Nothing,+	_ibCurrentlyLoadedSol  = Nothing+}++stateContextStorage :: IBStateContext -> Wire ImmutaballM (Maybe IBStateContext) IBStateContext+stateContextStorage y0 = proc cxt -> do+	hold y0 -< cxt++requireVideo :: Wire ImmutaballM IBStateContext IBStateContext+requireVideo = proc cxt0 -> do+	case ((cxt0^.ibContext.ibHeadless), (cxt0^.ibSDLWindow)) of+		(True, _)        -> returnA -< cxt0+		(False, Just _)  -> returnA -< cxt0+		(False, Nothing) -> do+			let windowTitle = T.pack "Immutaball"+			let windowCfg = SDL.defaultWindow {+				SDL.windowMode = if' (cxt0^.ibNeverballrc.fullscreen) SDL.Fullscreen SDL.Windowed,+				SDL.windowGraphicsContext = SDL.OpenGLContext (SDL.defaultOpenGL {SDL.glProfile = SDL.Compatibility SDL.Normal 4 5}),+				SDL.windowInitialSize = V2 (fromIntegral $ (cxt0^.ibNeverballrc.width)) (fromIntegral $ cxt0^.ibNeverballrc.height)+			}+			if not sdlNeedsSpecialThread+				then do+					window <- monadic -< liftIBIO . BasicIBIOF . SDLIO $ SDLWithWindow windowTitle windowCfg id+					context <- monadic -< liftIBIO . BasicIBIOF . SDLIO $ SDLWithGLContext window id+					let cxt1 = cxt0 & (ibSDLWindow.~Just (window :: SDL.Window)) . (ibSDLGLContext.~Just (context :: SDL.GLContext))+					returnA -< cxt1+				else do+					let h = cxt0^.ibContext.ibSDLManagerHandle+					mwindow <- monadic -< liftIBIO $ Atomically (newEmptyTMVar) id+					() <- monadic -< liftIBIO $ issueSDLCommand h (WithWindow windowTitle windowCfg mwindow) ()+					window <- monadic -< liftIBIO $ Atomically (readTMVar mwindow) id+					mcontext <- monadic -< liftIBIO $ Atomically (newEmptyTMVar) id+					() <- monadic -< liftIBIO $ issueSDLCommand h (WithGLContext window mcontext) ()+					context <- monadic -< liftIBIO $ Atomically (readTMVar mcontext) id+					let cxt1 = cxt0 & (ibSDLWindow.~Just (window :: SDL.Window)) . (ibSDLGLContext.~Just (context :: SDL.GLContext))+					returnA -< cxt1+	where+		sdlNeedsSpecialThread :: Bool+		sdlNeedsSpecialThread = True++requireShader :: Wire ImmutaballM IBStateContext (ImmutaballShaderHandle, IBStateContext)+requireShader = proc cxt0 -> do+	case (cxt0^.ibShader) of+		Just mshader -> monadic *** id -< (liftIBIO $ Atomically (readTMVar mshader) id, cxt0)+		Nothing -> do+			mshader <- monadic -< liftIBIO $ sdlCreateImmutaballShader (cxt0^.ibContext.ibSDLManagerHandle)+			let cxt1 = cxt0 & (ibShader.~Just mshader)+			shader <- monadic -< liftIBIO $ Atomically (readTMVar mshader) id+			returnA -< (shader, cxt1)++requireFont :: Wire ImmutaballM IBStateContext (SDL.Font.Font, IBStateContext)+requireFont = proc cxt0 -> do+	case (cxt0^.ibSDLFont) of+		Just font -> returnA -< (font, cxt0)+		Nothing -> do+			let path = cxt0^.ibContext.ibDirs.ibStaticDataDir </> cxt0^.ibContext.ibStaticConfig.immutaballFont+			let size = cxt0^.ibContext.ibStaticConfig.immutaballFontSize+			-- Since this is likely the first time a data file is accessed,+			-- check the path exists and warn if it doesn't with a helpful+			-- message that ‘-d data-path’ needs to be correct.+			exists <- monadic -< liftIBIO . BasicIBIOF $ DoesPathExistSync path id+			() <- warnIf -< (not exists, ("Warning: ./immutaball -d PATH_TO_DATA_DIR must be passed with a path to a compiled neverball data directory; failed to find font file: " ++ path))+			font <- monadic -< liftIBIO . BasicIBIOF . SDLIO $ SDLTTFLoad path (fromIntegral size) id+			let cxt1 = cxt0 & (ibSDLFont.~Just font)+			returnA -< (font, cxt1)+	where+		warnIf :: Wire ImmutaballM (Bool, String) ()+		warnIf = proc (condition, msg) -> do+			() <- monadic -< if' (not condition) (pure ()) . liftIBIO . BasicIBIOF $ PutStrLn msg ()+			returnA -< ()++requireGLTextureNames :: Wire ImmutaballM IBStateContext (TVar (S.Set GLuint, S.Set GLuint), IBStateContext)+requireGLTextureNames = proc cxt0 -> do+	case (cxt0^.ibGLTextureNames) of+		Just glTextureNames -> returnA -< (glTextureNames, cxt0)+		Nothing -> do+			glTextureNames <- monadic -< liftIBIO $ Atomically (newTVar (S.empty, S.empty)) id+			let cxt1 = cxt0 & (ibGLTextureNames.~Just glTextureNames)+			returnA -< (glTextureNames, cxt1)++requireGLTextTextures :: Wire ImmutaballM IBStateContext (TVar (M.Map T.Text (WidthHeightI, GLuint)), IBStateContext)+requireGLTextTextures = proc cxt0 -> do+	case (cxt0^.ibGLTextTextures) of+		Just glTextTextures -> returnA -< (glTextTextures, cxt0)+		Nothing -> do+			glTextTextures <- monadic -< liftIBIO $ Atomically (newTVar M.empty) id+			let cxt1 = cxt0 & (ibGLTextTextures.~Just glTextTextures)+			returnA -< (glTextTextures, cxt1)++requireGLMtrlTextures :: Wire ImmutaballM IBStateContext (TVar (M.Map String ((WidthHeightI, GLuint), MtrlMeta)), IBStateContext)+requireGLMtrlTextures = proc cxt0 -> do+	case (cxt0^.ibGLMtrlTextures) of+		Just glMtrlTextures -> returnA -< (glMtrlTextures, cxt0)+		Nothing -> do+			glMtrlTextures <- monadic -< liftIBIO $ Atomically (newTVar M.empty) id+			let cxt1 = cxt0 & (ibGLMtrlTextures.~Just glMtrlTextures)+			returnA -< (glMtrlTextures, cxt1)++-- | If you require this after you require the mtrl and text cache, you can+-- also free the text and mtrl cache on lifetime end.+requireGLAllocatedTextures :: Wire ImmutaballM IBStateContext (TVar (S.Set GLuint, S.Set GLuint), IBStateContext)+requireGLAllocatedTextures = proc cxt0 -> do+	case (cxt0^.ibGLAllocatedTextures) of+		Just glAllocatedTextures -> returnA -< (glAllocatedTextures, cxt0)+		Nothing -> do+			unusedTo_ <- monadic -< liftIBIO $ Atomically (newTMVar ()) id+			glAllocatedTextures <- monadic -< liftIBIO $ Atomically (newTVar (S.empty, S.empty)) id+			let cxt1 = cxt0 & (ibGLAllocatedTextures.~Just glAllocatedTextures)+			() <- monadic -< liftIBIO $ attachLifetime (cxt0^.ibContext.ibSDLManagerHandle) (pure ()) (\() -> void $ ibFreeAllTextures cxt1) unusedTo_ ()+			--returnA -< (glAllocatedTextures, cxt1)+			cxt2 <- checkPrecacheMtrls -< cxt1+			cxt3 <- checkPrecacheMisc -< cxt2+			returnA -< (glAllocatedTextures, cxt3)++requireSSBOs :: Wire ImmutaballM IBStateContext (TVar (M.Map GLuint GLuint), IBStateContext)+requireSSBOs = proc cxt0 -> do+	let sdlh = (cxt0^.ibContext.ibSDLManagerHandle)+	case (cxt0^.ibSSBOs) of+		Just ssbos -> returnA -< (ssbos, cxt0)+		Nothing -> do+			ssbos <- monadic -< liftIBIO $ Atomically (newTVar M.empty) id++			trivialResourceMetaStorage <- monadic -< liftIBIO $ Atomically (newTMVar ()) id  -- The resource is nothing but a destructor that frees the ssbo1.+			() <- monadic -< liftIBIO $ attachLifetime sdlh (pure ()) (\() -> void $ freeSSBOsIB sdlh ssbos) trivialResourceMetaStorage ()++			let cxt1 = cxt0 & (ibSSBOs.~Just ssbos)+			returnA -< (ssbos, cxt1)++requireElemVaoVboEbo :: Wire ImmutaballM IBStateContext (TMVar (GLuint, GLuint, GLuint), IBStateContext)+requireElemVaoVboEbo = proc cxt0 -> do+	let sdlh = (cxt0^.ibContext.ibSDLManagerHandle)+	case (cxt0^.ibElemVaoVboEbo) of+		Just elemVaoVboEbo -> returnA -< (elemVaoVboEbo, cxt0)+		Nothing -> do+			elemVaoVboEbo <- monadic -< liftIBIO $ Atomically (newEmptyTMVar) id++			trivialResourceMetaStorage <- monadic -< liftIBIO $ Atomically (newTMVar ()) id  -- The resource is nothing but a destructor that frees the ssbo1.+			() <- monadic -< liftIBIO $ attachLifetime sdlh (pure ()) (\() -> void $ freeElemVaoVboEboIB sdlh elemVaoVboEbo) trivialResourceMetaStorage ()++			let cxt1 = cxt0 & (ibElemVaoVboEbo.~Just elemVaoVboEbo)+			returnA -< (elemVaoVboEbo, cxt1)++requireBallElemVaoVboEbo :: Wire ImmutaballM IBStateContext (TMVar (GLuint, GLuint, GLuint), IBStateContext)+requireBallElemVaoVboEbo = proc cxt0 -> do+	let sdlh = (cxt0^.ibContext.ibSDLManagerHandle)+	case (cxt0^.ibBallElemVaoVboEbo) of+		Just ballElemVaoVboEbo -> returnA -< (ballElemVaoVboEbo, cxt0)+		Nothing -> do+			ballElemVaoVboEbo <- monadic -< liftIBIO $ Atomically (newEmptyTMVar) id++			trivialResourceMetaStorage <- monadic -< liftIBIO $ Atomically (newTMVar ()) id  -- The resource is nothing but a destructor that frees the ssbo1.+			() <- monadic -< liftIBIO $ attachLifetime sdlh (pure ()) (\() -> void $ freeBallElemVaoVboEboIB sdlh ballElemVaoVboEbo) trivialResourceMetaStorage ()++			let cxt1 = cxt0 & (ibBallElemVaoVboEbo.~Just ballElemVaoVboEbo)+			returnA -< (ballElemVaoVboEbo, cxt1)++requireLoadedSolStorage :: Wire ImmutaballM IBStateContext (TMVar String, IBStateContext)+requireLoadedSolStorage = proc cxt0 -> do+	case (cxt0^.ibCurrentlyLoadedSol) of+		Just mcurrentlyLoadedSol -> returnA -< (mcurrentlyLoadedSol, cxt0)+		Nothing -> do+			mcurrentlyLoadedSol <- monadic -< liftIBIO $ Atomically (newEmptyTMVar) id+			let cxt1 = cxt0 & (ibCurrentlyLoadedSol.~Just mcurrentlyLoadedSol)+			returnA -< (mcurrentlyLoadedSol, cxt1)++requireMisc :: Wire ImmutaballM IBStateContext IBStateContext+requireMisc =+	snd <$> requireLoadedSolStorage <<<+	snd <$> requireBallElemVaoVboEbo <<<+	snd <$> requireElemVaoVboEbo <<<+	snd <$> requireSSBOs <<<+	snd <$> requireShader <<< snd <$> requireGLAllocatedTextures <<<+	snd <$> requireGLMtrlTextures <<<+	snd <$> requireGLTextTextures <<< snd <$> requireGLTextureNames <<<+	snd <$> requireFont <<< id++-- | Also handles common set-up tasks like clearing the color for rendering.+requireBasics :: Wire ImmutaballM (IBStateContext, Request) IBStateContext+requireBasics = proc (cxt0, _request) -> do+	cxtn <- requireMisc <<< requireVideo -< cxt0+	let sdlGL1' = liftIBIO . sdlGL1 (cxtn^.ibContext.ibSDLManagerHandle)+	() <- monadic -< sdlGL1' $ do+		GLClearColor 0.1 0.1 0.9 1.0 ()+		GLClear (GL_COLOR_BUFFER_BIT .|. GL_DEPTH_BUFFER_BIT .|. GL_STENCIL_BUFFER_BIT) ()+	returnA -< cxtn++-- | Handles common frame finishing like swapping the scene on paint.+--+-- Currently does not update the state context, so it outputs ().+finishFrame :: Wire ImmutaballM (Request, IBStateContext) ()+finishFrame = proc (request, cxt) -> do+	() <- nopA ||| finishFramePaint -< const () +++ const cxt $ matching _Paint request+	returnA -< ()++finishFramePaint :: Wire ImmutaballM IBStateContext ()+finishFramePaint = proc cxt -> do+	-- Swapping outside the SDL Manager thread on my platform didn't work.  So+	-- we'll have the SDL Manager thread do it.+	() <- monadic -<+		if' (not sdlNeedsSpecialThread)+			(maybe (pure ()) (liftIBIO . BasicIBIOF . SDLIO . flip SDLGLSwapWindow ()) $ (cxt^.ibSDLWindow))+			(maybe (pure ()) (liftIBIO . flip (sdlGLSwapWindow (cxt^.ibContext.ibSDLManagerHandle)) ()) $ (cxt^.ibSDLWindow))+	() <- checkGLErrors -< ()+	returnA -< ()+	where+		sdlNeedsSpecialThread :: Bool+		sdlNeedsSpecialThread = True++checkGLErrors :: Wire ImmutaballM () ()+checkGLErrors = proc () -> do+	error_ <- monadic -< liftIBIO . BasicIBIOF . GLIO $ GLGetError id+	case error_ of+		GL_NO_ERROR -> returnA -< ()+		err -> do+			() <- monadic -< liftIBIO . BasicIBIOF $ PutStrLn ("Error: an OpenGL error occurred (" ++ show err ++ "): " ++ glErrType err) ()+			() <- monadic -< liftIBIO . BasicIBIOF $ ExitFailureBasicIOF+			returnA -< ()++-- * Utils++-- | This variant does NOT use ibGLAllocatedTextures, so lifetimes would need+-- to be manually managed.  (This is because I'm currently not using this+-- variant.)+--+-- Edit: actually we need glGenTextures to create names.+-- So don't use the 'WithoutGenText' versions since they won't work.+newTextureNameWithoutGenText :: Wire ImmutaballM IBStateContext (GLuint, IBStateContext)+newTextureNameWithoutGenText = proc cxtn -> do+	(glTextureNames, cxtnp1) <- requireGLTextureNames -< cxtn+	(name, err) <- monadic -< liftIBIO . flip Atomically id $ do+		(used, freed) <- readTVar glTextureNames+		let defaultName = fromMaybe 0 $ (+1) <$> S.lookupMax used+		let name = fromMaybe defaultName $ S.lookupMin freed+		let (used', freed') = (S.insert name used, S.delete name freed)+		writeTVar glTextureNames (used', freed')+		let err = if' (not $ name `S.member` used) Nothing $ Just ("Error: newTextureName: created texture name already in use!: " ++ show name)+		return (name, err)+	() <- monadic -< flip (maybe $ pure ()) err $ \errMsg -> liftIBIO $ (BasicIBIOF $ PutStrLn errMsg ()) <>>- BasicIBIOF ExitFailureBasicIOF+	returnA -< (name, cxtnp1)++freeTextureNameWithoutGenText :: Wire ImmutaballM (GLuint, IBStateContext) IBStateContext+freeTextureNameWithoutGenText = proc (name, cxtn) -> do+	(glTextureNames, cxtnp1) <- requireGLTextureNames -< cxtn+	err <- monadic -< liftIBIO . flip Atomically id $ do+		(used, freed) <- readTVar glTextureNames+		let (used', freed') = (S.delete name used, S.insert name freed)+		writeTVar glTextureNames (used', freed')+		let err =+			if' (name `S.member` freed)       (Just ("Error: freeTextureName: double free of texture name!: " ++ show name)) .+			if' (not $ name `S.member` used)  (Just ("Error: freeTextureName: free of unallocated texture name!: " ++ show name)) $+			Nothing+		return err+	() <- monadic -< flip (maybe $ pure ()) err $ \errMsg -> liftIBIO $ (BasicIBIOF $ PutStrLn errMsg ()) <>>- BasicIBIOF ExitFailureBasicIOF+	returnA -< cxtnp1++-- | Generate a new texture name.+--+-- Also track its lifetime in ibGLAllocatedTextures, so that ibFreeTextures can+-- be attached to the SDL Manager thread to free all remaining on quit.+newTextureName :: Wire ImmutaballM IBStateContext (GLuint, IBStateContext)+newTextureName = proc cxtn -> do+	(glAllocatedTextures, cxtnp1) <- requireGLAllocatedTextures -< cxtn++	(sdlGL1' :: GLIOF me -> ImmutaballM me) <- returnA -< liftIBIO . sdlGL1 (cxtnp1^.ibContext.ibSDLManagerHandle)+	name <- monadic -< (unSingleton <$>) . sdlGL1' $ GLGenTextures 1 id+	-- Now track in ibGLAllocatedTextures.+	() <- monadic -< liftIBIO . flip Atomically id $ do+		let musedFree = glAllocatedTextures+		usedFree0 <- readTVar musedFree+		let (used0, free0) = usedFree0+		let (used1, free1) = (S.insert name used0, free0)+		let usedFree1 = (used1, free1)+		writeTVar musedFree usedFree1+	returnA -< (name, cxtnp1)+	where+		unSingleton [me] = me+		unSingleton _    = error "Internal error: newTextureName expected a single result from GLGenTextures."++freeTextureName :: Wire ImmutaballM (GLuint, IBStateContext) IBStateContext+freeTextureName = proc (name, cxtn) -> do+	(glAllocatedTextures, cxtnp1) <- requireGLAllocatedTextures -< cxtn++	(sdlGL1' :: GLIOF me -> ImmutaballM me) <- returnA -< liftIBIO . sdlGL1 (cxtnp1^.ibContext.ibSDLManagerHandle)+	() <- monadic -< sdlGL1' $ GLDeleteTextures [name] ()+	-- Now free in ibGLAllocatedTextures - just mark it as freed rather than+	-- used.+	() <- monadic -< liftIBIO . flip Atomically id $ do+		let musedFree = glAllocatedTextures+		usedFree0 <- readTVar musedFree+		let (used0, free0) = usedFree0+		let (used1, free1) = (S.delete name used0, if' keepTrackOfFreedTextureNames (S.insert name free0) free0)+		let usedFree1 = (used1, free1)+		writeTVar musedFree usedFree1+	returnA -< cxtnp1+	where+		keepTrackOfFreedTextureNames :: Bool+		keepTrackOfFreedTextureNames = False++-- | Tight RGBA.+createTexture :: Wire ImmutaballM ((WidthHeightI, BS.ByteString), IBStateContext) (GLuint, IBStateContext)+createTexture = proc (((w, h), image), cxtn) -> do+	(name, cxtnp1) <- newTextureName -< cxtn+	(sdlGL1' :: GLIOF me -> ImmutaballM me) <- returnA -< liftIBIO . sdlGL1 (cxtnp1^.ibContext.ibSDLManagerHandle)+	() <- monadic -< sdlGL1' $ 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_TEXTURE_2D ()+		GLActiveTexture GL_TEXTURE0 ()+		GLClientActiveTexture GL_TEXTURE0 ()+		GLBindTexture GL_TEXTURE_2D name ()+		let glImage = reverseRowsImage ((w, h), image)+		GLTexImage2D GL_TEXTURE_2D 0 GL_RGBA (fromIntegral w) (fromIntegral h) 0 GL_RGBA GL_UNSIGNED_BYTE glImage ()+		-- TODO: re-enable after mipmap is fixed.+		--when (cxtnp1^.ibNeverballrc.mipmap) $ do+		--	GLGenerateMipmap name ()++		GLTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_REPEAT ()+		GLTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_REPEAT ()+		-- TODO: re-enable after mipmap is fixed.+		{-+		when (      cxtnp1^.ibNeverballrc.mipmap) $ do+			GLTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR_MIPMAP_LINEAR ()+			GLTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR_MIPMAP_LINEAR ()+		when (not $ cxtnp1^.ibNeverballrc.mipmap) $ do+		-}+		when True $ do+			GLTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR ()+			GLTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR ()++		GLTexParameterfv GL_TEXTURE_2D GL_TEXTURE_BORDER_COLOR [0.0, 0.0, 0.0, 0.0] ()++	returnA -< (name, cxtnp1)++-- | This also frees the texture, not just the name.+freeTexture :: Wire ImmutaballM (GLuint, IBStateContext) IBStateContext+freeTexture = proc (name, cxtn) -> do+	cxtnp1 <- freeTextureName -< (name, cxtn)+	returnA -< cxtnp1++-- | Render a text.+--+-- Since rending a text may have a cost, hold onto the texture until its freed+-- with 'uncacheText'.+cachingRenderText :: Wire ImmutaballM (T.Text, IBStateContext) ((WidthHeightI, GLuint), IBStateContext)+cachingRenderText = proc (text, cxtn) -> do+	(mglTextTextures, cxtnp1) <- requireGLTextTextures -< cxtn+	(sdl' :: SDLIOF me -> ImmutaballM me) <- returnA -< liftIBIO . sdl (cxtnp1^.ibContext.ibSDLManagerHandle)+	glTextTextures <- monadic -< liftIBIO $ Atomically (readTVar mglTextTextures) id+	case M.lookup text glTextTextures of+		Just ((w, h), name) -> do+			returnA -< (((w, h), name), cxtnp1)+		Nothing -> do+			(font, cxtnp2) <- requireFont -< cxtnp1+			-- We were doing it ourselves, but it's unclear if it's designed to+			-- work outside the SDL thread.+			--((w, h), image) <- monadic -< liftIBIO . BasicIBIOF . SDLIO $ SDLTTFRenderSync font text id+			((w, h), image) <- monadic -< sdl' $ SDLTTFRenderSync font text id+			(name, cxtnp3) <- createTexture -< (((w, h), image), cxtnp2)+			-- Also see if somebody already cached our text while we were+			-- creating the texture.+			raceAlreadyCached <- monadic -< liftIBIO . flip Atomically id $ do+				glTextTextures2 <- readTVar mglTextTextures+				case M.lookup text glTextTextures2 of+					Nothing -> do+						let glTextTextures3 = M.insert text ((w, h), name) glTextTextures2+						writeTVar mglTextTextures glTextTextures3+						return Nothing+					Just ((w2, h2), name2) -> do+						return $ Just ((w2, h2), name2)+			case raceAlreadyCached of+				Nothing -> do returnA -< (((w, h), name), cxtnp3)+				Just ((w2, h2), name2) -> do+					cxtnp4 <- freeTexture -< (name, cxtnp3)+					returnA -< (((w2, h2), name2), cxtnp4)++-- | Can be repeated; does not if no cache exists for the text.+--+-- Delete the texture and free its texture name if the text has a texture+-- created for it.+uncacheText :: Wire ImmutaballM (T.Text, IBStateContext) IBStateContext+uncacheText = proc (text, cxtn) -> do+	(mglTextTextures, cxtnp1) <- requireGLTextTextures -< cxtn+	mname <- monadic -< liftIBIO . flip Atomically id $ do+		glTextTextures <- readTVar mglTextTextures+		let glTextTextures2 = M.delete text glTextTextures+		writeTVar mglTextTextures glTextTextures2+		return $ snd <$> M.lookup text glTextTextures+	case mname of+		Nothing -> returnA -< cxtnp1+		Just name -> do+			cxtnp2 <- freeTexture -< (name, cxtnp1)+			returnA -< cxtnp2++clearTextCache :: Wire ImmutaballM IBStateContext IBStateContext+clearTextCache = proc cxtn -> do+	(mglTextTextures, cxtnp1) <- requireGLTextTextures -< cxtn+	glTextTextures <- monadic -< liftIBIO $ Atomically (readTVar mglTextTextures) id+	let (texts :: [T.Text]) = M.keys glTextTextures+	foldrA uncacheText -< (cxtnp1, texts)++-- | This only frees allocated textures; it does not update the text texture ID+-- or mtrl texture ID cache.  To clear everything use 'freeAllTextures'.+freeTextures :: Wire ImmutaballM IBStateContext IBStateContext+freeTextures = proc cxtn -> do+	(musedFree, cxtnp1) <- requireGLAllocatedTextures -< cxtn+	needsFreeing <- monadic -< liftIBIO . flip Atomically id $ do+		usedFree0 <- readTVar musedFree+		let (used0, free0) = usedFree0+		let needsFreeing = used0+		let free1 = used0 `S.union` free0+		let used1 = S.empty+		let usedFree1 = (used1, free1)+		writeTVar musedFree (if' weManageAllTextures usedFree1 usedFree0)+		return needsFreeing+	cxtnp2 <- foldrA freeTexture -< (cxtnp1, needsFreeing)+	returnA -< cxtnp2+	where+		weManageAllTextures :: Bool+		weManageAllTextures = False++-- | You can use this to attach a resource using this to the SDLManager thread to+-- free all textures on exit.  The state context can be old so long as it still+-- has the same STM references.+--+-- This only frees allocated textures; it does not update the text texture ID+-- or mtrl texture ID cache.  To clear everything use 'ibFreeAllTextures'.+ibFreeTextures :: IBStateContext -> ImmutaballIOF IBStateContext+ibFreeTextures cxt0 = (\w -> fst <$> stepImmutaballWire w cxt0) $ freeTextures++uncacheMtrl :: Wire ImmutaballM (String, IBStateContext) IBStateContext+uncacheMtrl = proc (mtrl, cxtn) -> do+	(mglMtrlTextures, cxtnp1) <- requireGLMtrlTextures -< cxtn+	mname <- monadic -< liftIBIO . flip Atomically id $ do+		glMtrlTextures <- readTVar mglMtrlTextures+		let glMtrlTextures2 = M.delete mtrl glMtrlTextures+		writeTVar mglMtrlTextures glMtrlTextures2+		return $ snd . fst <$> M.lookup mtrl glMtrlTextures+	case mname of+		Nothing -> returnA -< cxtnp1+		Just name -> do+			cxtnp2 <- freeTexture -< (name, cxtnp1)+			returnA -< cxtnp2++clearMtrlCache :: Wire ImmutaballM IBStateContext IBStateContext+clearMtrlCache = proc cxtn -> do+	(mglMtrlTextures, cxtnp1) <- requireGLMtrlTextures -< cxtn+	glMtrlTextures <- monadic -< liftIBIO $ Atomically (readTVar mglMtrlTextures) id+	let (mtrls :: [String]) = M.keys glMtrlTextures+	foldrA uncacheMtrl -< (cxtnp1, mtrls)++freeAllTextures :: Wire ImmutaballM IBStateContext IBStateContext+freeAllTextures = proc cxtn -> do+	cxtnp1 <- clearMtrlCache -< cxtn+	cxtnp2 <- clearTextCache -< cxtnp1+	cxtnp3 <- freeTextures   -< cxtnp2+	returnA -< cxtnp3++ibFreeAllTextures :: IBStateContext -> ImmutaballIOF IBStateContext+ibFreeAllTextures cxt0 = (\w -> fst <$> stepImmutaballWire w cxt0) $ freeAllTextures++-- | Give it a material path, like ‘mtrl/invisible’.+--+-- TODO: implement more full support for mtrl textures.  For now just read the+-- base image file for the texture, inside ‘data/textures/mtrl/’.+cachingRenderMtrl :: Wire ImmutaballM (String, IBStateContext) (((WidthHeightI, GLuint), MtrlMeta), IBStateContext)+cachingRenderMtrl = proc (mtrl, cxtn) -> do+	(mglMtrlTextures, cxtnp1) <- requireGLMtrlTextures -< cxtn+	glMtrlTextures <- monadic -< liftIBIO $ Atomically (readTVar mglMtrlTextures) id+	case M.lookup mtrl glMtrlTextures of+		Just (((w, h), name), meta) -> do+			returnA -< ((((w, h), name), meta), cxtnp1)+		Nothing -> do+			-- Find (((w, h), image), meta).+			let texturesDir = cxtnp1^.ibContext.ibDirs.ibStaticDataDir </> "textures"+			let baseMtrlPath = texturesDir </> mtrl+			let mtrlMetaPath = baseMtrlPath+			let mtrlImageTryPaths = [baseMtrlPath ++ ".png", baseMtrlPath ++ ".jpg"]++			ammtrlMetaContents <- monadic -< liftIBIO . BasicIBIOF $ ReadText mtrlMetaPath id+			ammtrlEncodedImages <- monadic -< liftIBIO . BasicIBIOF $ forM mtrlImageTryPaths $ \mtrlImageTryPath -> ReadBytes mtrlImageTryPath id+			mmtrlMetaContents <- monadic -< liftIBIO $ Wait ammtrlMetaContents id+			mmtrlEncodedImages <- monadic -< liftIBIO . forM ammtrlEncodedImages $ \ammtrlEncodedImage -> Wait ammtrlEncodedImage id++			mtrlMetaContents <- monadic -< liftIBIO . (ThrowIO ||| pure) $ mmtrlMetaContents+			let (mtrlEncodedImagesFailures, mtrlEncodedImages) = partitionEithers mmtrlEncodedImages+			mtrlEncodedImage <- monadic -< liftIBIO $ case (mtrlEncodedImagesFailures, mtrlEncodedImages) of+				(errs@(err:_), []) -> do+					BasicIBIOF $ PutStrLn (printf "Error: cachingRenderMtrl %s: failed to read mtrl texture image: %s" mtrl (intercalate "\n" (map show errs))) ()+					ThrowIO err+				([], []) -> ThrowIO $ userError ("Error: cachingRenderMtrl: no errors or successes when reading the mtrl " ++ mtrl)+				(_, [encodedImage]) -> return encodedImage+				(_, (_encodedImages@(encodedImage:_more))) -> do+					BasicIBIOF $ PutStrLn (printf "Warning: cachingRenderMtrl %s: found multiple mtrl images; using the first" mtrl) ()+					return encodedImage+			let mmtrlJpEncodedImage = JP.decodeImage . BL.toStrict $ mtrlEncodedImage+			mtrlJpEncodedImage <- monadic -< liftIBIO . (ThrowIO . (\e -> userError (printf "Error: cachingRenderMtrl %s: failed to decode texture image!: %s" mtrl e)) ||| pure) $ mmtrlJpEncodedImage+			let mtrlJpImage = juicyPixelsDynamicImageToJPImage mtrlJpEncodedImage+			let (mtrlW, mtrlH) = join (***) fromIntegral (JP.imageWidth mtrlJpImage, JP.imageHeight mtrlJpImage)+			let mtrlImage = juicyPixelsImageToImage mtrlJpImage+			let mtrlImageGL = reverseRowsImage ((mtrlW, mtrlH), mtrlImage)+			let mtrlMeta = MtrlMeta+			let _unused = [mtrlMetaContents]++			let (((w, h), image), meta) = (((mtrlW, mtrlH), mtrlImageGL), mtrlMeta)++			-- Make the texture with (((w, h), image), meta).+			(name, cxtnp3) <- createTexture -< (((w, h), image), cxtnp1)+			-- Also see if somebody already cached our text while we were+			-- creating the texture.+			raceAlreadyCached <- monadic -< liftIBIO . flip Atomically id $ do+				glMtrlTextures2 <- readTVar mglMtrlTextures+				case M.lookup mtrl glMtrlTextures2 of+					Nothing -> do+						let glMtrlTextures3 = M.insert mtrl (((w, h), name), meta) glMtrlTextures2+						writeTVar mglMtrlTextures glMtrlTextures3+						return Nothing+					Just (((w2, h2), name2), meta2) -> do+						return $ Just (((w2, h2), name2), meta2)+			case raceAlreadyCached of+				Nothing -> do returnA -< ((((w, h), name), meta), cxtnp3)+				Just (((w2, h2), name2), meta2) -> do+					cxtnp4 <- freeTexture -< (name, cxtnp3)+					returnA -< ((((w2, h2), name2), meta2), cxtnp4)++-- | Convert a JuicyPixels image to our own RGBA pixel format.+juicyPixelsDynamicImageToJPImage :: JP.DynamicImage -> JP.Image JP.PixelRGBA8+juicyPixelsDynamicImageToJPImage (JP.ImageY8     img) = JP.promoteImage img+juicyPixelsDynamicImageToJPImage (JP.ImageY16    img) = juicyPixelsDynamicImageToJPImage . JP.ImageRGBA16 $ JP.promoteImage img+juicyPixelsDynamicImageToJPImage (JP.ImageY32    img) = flip JP.pixelMap img $ \pixel -> (\c -> JP.PixelRGBA8 c c c 255) $ (round $ (fromIntegral pixel / (4294967295  :: Double))*255)+juicyPixelsDynamicImageToJPImage (JP.ImageYF     img) = flip JP.pixelMap img $ \pixel -> (\c -> JP.PixelRGBA8 c c c 255) $ (round $ pixel*255)+juicyPixelsDynamicImageToJPImage (JP.ImageYA8    img) = JP.promoteImage img+juicyPixelsDynamicImageToJPImage (JP.ImageYA16   img) = juicyPixelsDynamicImageToJPImage . JP.ImageRGBA16 $ JP.promoteImage img+juicyPixelsDynamicImageToJPImage (JP.ImageRGB8   img) = JP.promoteImage img+juicyPixelsDynamicImageToJPImage (JP.ImageRGB16  img) = flip JP.pixelMap img $ \(JP.PixelRGB16 r g b) -> JP.PixelRGBA8 (round $ ((fromIntegral r  :: Double) / 65535.0)*255) (round $ ((fromIntegral g  :: Double) / 65535.0)*255) (round $ ((fromIntegral b  :: Double) / 65535.0)*255) 255+juicyPixelsDynamicImageToJPImage (JP.ImageRGBF   img) = flip JP.pixelMap img $ \(JP.PixelRGBF r g b) -> JP.PixelRGBA8 (round $ r*255) (round $ g*255) (round $ b*255) (255)+juicyPixelsDynamicImageToJPImage (JP.ImageRGBA8  img) = img+juicyPixelsDynamicImageToJPImage (JP.ImageRGBA16 img) = flip JP.pixelMap img $ \(JP.PixelRGBA16 r g b a) -> JP.PixelRGBA8 (round $ ((fromIntegral r  :: Double) / 65535.0)*255) (round $ ((fromIntegral g  :: Double) / 65535.0)*255) (round $ ((fromIntegral b  :: Double) / 65535.0)*255) (round $ ((fromIntegral a  :: Double) / 65535.0)*255)+juicyPixelsDynamicImageToJPImage (JP.ImageYCbCr8 img) = juicyPixelsDynamicImageToJPImage . JP.ImageRGB8  $ JP.convertImage img+juicyPixelsDynamicImageToJPImage (JP.ImageCMYK8  img) = juicyPixelsDynamicImageToJPImage . JP.ImageRGB8  $ JP.convertImage img+juicyPixelsDynamicImageToJPImage (JP.ImageCMYK16 img) = juicyPixelsDynamicImageToJPImage . JP.ImageRGB16 $ JP.convertImage img++juicyPixelsImageToImage :: JP.Image JP.PixelRGBA8 -> BS.ByteString+juicyPixelsImageToImage jpImage@(JP.Image w h _) = BL.toStrict . BB.toLazyByteString $ JP.pixelFold (\builder _ _ (JP.PixelRGBA8 r g b a) -> builder <> BB.word8 r <> BB.word8 g <> BB.word8 b <> BB.word8 a) mempty jpImage+	where+		_w', _h' :: Integer+		(_w', _h') = join (***) fromIntegral (w, h)++-- | If the context enables precaching mtrls, spawn a thread to precache them.+checkPrecacheMtrls :: Wire ImmutaballM IBStateContext IBStateContext+checkPrecacheMtrls = proc cxtn -> do+	--cxtnp1 <- if' (cxtn^.ibContext.ibStaticConfig.x'cfgPrecacheMtrls) precacheMtrls returnA -<< cxtn+	cxtnp1 <- replaceNow $ (proc (_cxt, doPrecacheMtrls) -> do+		returnA -< if' (not doPrecacheMtrls) (arr fst) $ proc (cxt2, _doPrecacheMtrls) -> do+			precacheMtrls -< cxt2+		) -< (cxtn, (cxtn^.ibContext.ibStaticConfig.x'cfgPrecacheMtrls))+	returnA -< cxtnp1++-- | Spawn a thread to scan for mtrls and render them to the cache.+precacheMtrls :: Wire ImmutaballM IBStateContext IBStateContext+precacheMtrls = proc cxtn -> do+	cxtnp1      <- requireVideo               -< cxtn+	(_, cxtnp2) <- requireGLTextureNames      -< cxtnp1+	(_, cxtnp3) <- requireGLTextTextures      -< cxtnp2+	(_, cxtnp4) <- requireGLMtrlTextures      -< cxtnp3+	(_, cxtnp5) <- requireGLAllocatedTextures -< cxtnp4++	-- TODO: the former uses async concurrency so exceptions are noticed and so+	-- on, which would be preferable, but FIXME it causes an exception to be+	-- thrown when the application quits.  Use the latter in the meantime.+	--() <- monadic -< liftIBIO $ forkIBIOF (void $ precacheMtrlsIB cxtnp5) (pure ())+	() <- monadic -< liftIBIO . JoinIBIOF . BasicIBIOF $ ForkIO (void $ precacheMtrlsIB cxtnp5) (pure ())++	returnA -< cxtnp5++-- | The mtrl precaching thread.+--+-- Ensure the STM resources have been allocated before calling.+precacheMtrlsIB :: IBStateContext -> ImmutaballIOF IBStateContext+precacheMtrlsIB cxt0 = ((\w -> fst <$> stepImmutaballWire w cxt0)) $ precacheMtrlsDirect++precacheMtrlsDirect :: Wire ImmutaballM IBStateContext IBStateContext+precacheMtrlsDirect = proc cxtn -> do+	let texturesDir = cxtn^.ibContext.ibDirs.ibStaticDataDir </> "textures"+	let mtrlsDir = texturesDir </> "mtrl"+	amtrlsDirContents <- monadic -< liftIBIO . BasicIBIOF $ GetDirectoryContents mtrlsDir id+	mtrlsDirContents <- monadic -< liftIBIO $ Wait amtrlsDirContents id+	let mtrlsBase_ = flip filter mtrlsDirContents $ \path -> not (path `elem` [".", ".."]) && not (".png" `isSuffixOf` path) && not (".jpg" `isSuffixOf` path) && path /= "default"+	let mtrlsBase = S.toList . S.fromList $ mtrlsBase_+	let mtrls = map ("mtrl" </>) mtrlsBase+	foldrA (proc (mtrlBase, cxt) -> snd <$> cachingRenderMtrl' -< (mtrlBase, cxt)) -< (cxtn, mtrls)+	-- Delay 100ms between materials to not congest the SDL manager thread.+	where cachingRenderMtrl' = proc (mtrl, cxt) -> do+		cxtnp1 <- cachingRenderMtrl -< (mtrl, cxt)+		() <- monadic -< liftIBIO . BasicIBIOF $ DelayUs (100*1000) ()+		returnA -< cxtnp1++-- | If the context enables precaching misc when setting up allocated textures, spawn a thread to perform misc precaching.+checkPrecacheMisc :: Wire ImmutaballM IBStateContext IBStateContext+checkPrecacheMisc = proc cxtn -> do+	--cxtnp1 <- if' (cxtn^.ibContext.ibStaticConfig.x'cfgPrecacheMisc) precacheMisc returnA -<< cxtn+	cxtnp1 <- replaceNow $ (proc (_cxt, doPrecacheMisc) -> do+		returnA -< if' (not doPrecacheMisc) (arr fst) $ proc (cxt2, _doPrecacheMisc) -> do+			precacheMisc -< cxt2+		) -< (cxtn, (cxtn^.ibContext.ibStaticConfig.x'cfgPrecacheMisc))+	returnA -< cxtnp1++-- | Spawn a thread to perform misc precaching.+precacheMisc :: Wire ImmutaballM IBStateContext IBStateContext+precacheMisc = proc cxtn -> do+	cxtnp1      <- requireVideo               -< cxtn+	(_, cxtnp2) <- requireGLTextureNames      -< cxtnp1+	(_, cxtnp3) <- requireGLTextTextures      -< cxtnp2+	(_, cxtnp4) <- requireGLAllocatedTextures -< cxtnp3+	(_, cxtnp5) <- requireFont                -< cxtnp4++	-- TODO: the former uses async concurrency so exceptions are noticed and so+	-- on, which would be preferable, but FIXME it causes an exception to be+	-- thrown when the application quits.  Use the latter in the meantime.+	--() <- monadic -< liftIBIO $ forkIBIOF (void $ precacheMiscIB cxtnp5) (pure ())+	() <- monadic -< liftIBIO . JoinIBIOF . BasicIBIOF $ ForkIO (void $ precacheMiscIB cxtnp5) (pure ())++	returnA -< cxtnp5++-- | The misc precaching thread.+--+-- Ensure the STM resources have been allocated before calling.+precacheMiscIB :: IBStateContext -> ImmutaballIOF IBStateContext+precacheMiscIB cxt0 = ((\w -> fst <$> stepImmutaballWire w cxt0)) $ precacheMiscDirect++precacheMiscDirect :: Wire ImmutaballM IBStateContext IBStateContext+precacheMiscDirect = proc cxtn -> do+	-- Just precache common timer texts: ":" and "00" through "99".+	let showI i = show (i :: Integer)+	let texts = map T.pack . concat $+		[+			[":"],+			[r | d1 <- [0..9], d2_ <- [0..9], r <- return $ showI d1 ++ showI d2_],+			[]+		]++	foldrA (proc (text, cxt) -> snd <$> cachingRenderText' -< (text, cxt)) -< (cxtn, texts)+	-- Delay 11ms between materials to not congest the SDL manager thread.+	where cachingRenderText' = proc (text, cxt) -> do+		cxtnp1 <- cachingRenderText -< (text, cxt)+		() <- monadic -< liftIBIO . BasicIBIOF $ DelayUs (11*1000) ()+		returnA -< cxtnp1++freeSSBOs :: Wire ImmutaballM IBStateContext IBStateContext+freeSSBOs = proc cxtn -> do+	(ssbos, cxtnp1) <- requireSSBOs -< cxtn+	() <- monadic -< liftIBIO $ freeSSBOsIB (cxtn^.ibContext.ibSDLManagerHandle) ssbos+	returnA -< cxtnp1++freeSSBOsIB :: SDLManagerHandle -> TVar (M.Map GLuint GLuint) -> ImmutaballIOF ()+freeSSBOsIB sdlh ssbos = do+	ssbosMap <- flip Atomically id $ do+		ssbosMap <- readTVar ssbos+		writeTVar ssbos M.empty+		return ssbosMap+	let ssbosVals = M.toList ssbosMap+	sdlGL1 sdlh $ do+		forM_ ssbosVals $ \(_location, ssbo) -> do+			GLDeleteBuffers [ssbo] ()++freeElemVaoVboEbo :: Wire ImmutaballM IBStateContext IBStateContext+freeElemVaoVboEbo = proc cxtn -> do+	(melemVaoVboEbo, cxtnp1) <- requireElemVaoVboEbo -< cxtn+	() <- monadic -< liftIBIO $ freeElemVaoVboEboIB (cxtn^.ibContext.ibSDLManagerHandle) melemVaoVboEbo+	returnA -< cxtnp1++freeBallElemVaoVboEbo :: Wire ImmutaballM IBStateContext IBStateContext+freeBallElemVaoVboEbo = proc cxtn -> do+	(mballElemVaoVboEbo, cxtnp1) <- requireBallElemVaoVboEbo -< cxtn+	() <- monadic -< liftIBIO $ freeBallElemVaoVboEboIB (cxtn^.ibContext.ibSDLManagerHandle) mballElemVaoVboEbo+	returnA -< cxtnp1++freeElemVaoVboEboIB :: SDLManagerHandle -> TMVar (GLuint, GLuint, GLuint) -> ImmutaballIOF ()+freeElemVaoVboEboIB sdlh elemVaoVboEbo = do+	mvaoVboEbo <- Atomically (tryTakeTMVar elemVaoVboEbo) id+	case mvaoVboEbo of+		Nothing -> return ()+		Just vaoVboEbo -> sdlGL1 sdlh $ do+			let (elemVao, elemVbo, elemEbo) = vaoVboEbo+			GLDeleteVertexArrays [elemVao] ()+			GLDeleteBuffers      [elemVbo] ()+			GLDeleteBuffers      [elemEbo] ()++freeBallElemVaoVboEboIB :: SDLManagerHandle -> TMVar (GLuint, GLuint, GLuint) -> ImmutaballIOF ()+freeBallElemVaoVboEboIB sdlh ballElemVaoVboEbo = do+	mvaoVboEbo <- Atomically (tryTakeTMVar ballElemVaoVboEbo) id+	case mvaoVboEbo of+		Nothing -> return ()+		Just vaoVboEbo -> sdlGL1 sdlh $ do+			let (elemVao, elemVbo, elemEbo) = vaoVboEbo+			GLDeleteVertexArrays [elemVao] ()+			GLDeleteBuffers      [elemVbo] ()+			GLDeleteBuffers      [elemEbo] ()++setSSBO :: Wire ImmutaballM ((GLuint, GLData), IBStateContext) IBStateContext+setSSBO = proc ((location, data_), cxtn) -> do+	(ssbos, cxtnp1) <- requireSSBOs -< cxtn++	-- First create and upload the SSBO before we expose its ID in the ssbo+	-- storage in the IBStateContext for ability to be freed.+	let sdlGL1' = liftIBIO . sdlGL1 (cxtnp1^.ibContext.ibSDLManagerHandle)+	newSSBO <- monadic -< sdlGL1' $ do+		-- Create the buffer.+		newSSBO <- unSingleton <$> GLGenBuffers 1 id++		-- Upload the data and assign the location (17).+		GLBindBuffer     GL_SHADER_STORAGE_BUFFER newSSBO ()+		GLBufferData     GL_SHADER_STORAGE_BUFFER data_ GL_STATIC_DRAW ()+		GLBindBufferBase GL_SHADER_STORAGE_BUFFER location newSSBO ()+		GLBindBuffer     GL_SHADER_STORAGE_BUFFER 0 ()++		-- Return the handle.+		return newSSBO++	-- Now insert the SSBO into the state context storage, swapping out the old+	-- one if there is an old one, noting it for freeing.+	moldSSBO <- monadic -< liftIBIO . flip Atomically id $ do+		ssbosVal <- readTVar ssbos+		let moldSSBO = M.lookup location ssbosVal+		let ssbosVal' = M.insert location newSSBO ssbosVal+		writeTVar ssbos ssbosVal'+		return moldSSBO++	-- If there was an old SSBO we replaced, free it.+	() <- monadic -< case moldSSBO of+		Nothing      -> pure ()+		Just oldSSBO -> liftIBIO . sdlGL1 (cxtnp1^.ibContext.ibSDLManagerHandle) $ do+			GLDeleteBuffers [oldSSBO] ()++	-- Return the new storage context.+	returnA -< cxtnp1++	where+		unSingleton [me] = me+		unSingleton _    = error "Internal error: setSSBO expected a single result from GLGenBuffers."++-- | Bool: set int32 vertex attrib?+setElemVaoVboEbo :: Wire ImmutaballM (GLData, Bool, IBStateContext) IBStateContext+setElemVaoVboEbo = proc (data_, setAttrib, cxtn) -> do+	(melemVaoVboEbo, cxtnp1) <- requireElemVaoVboEbo -< cxtn+	let sdlh = (cxtnp1^.ibContext.ibSDLManagerHandle)++	-- First create a new vao and buf, before exposing its ID to possible+	-- concurrency problems.+	newElemVaoVboEbo <- monadic -< liftIBIO . sdlGL1 sdlh $ do+		-- Create a new array and raw buffer of the array.+		elemVao <- unSingleton <$> GLGenVertexArrays 1 id+		elemVbo <- unSingleton <$> GLGenBuffers      1 id+		elemEbo <- unSingleton <$> GLGenBuffers      1 id++		-- Set the data, making it available for upload to the GPU.+		GLBindVertexArray elemVao ()++		GLBindBuffer GL_ELEMENT_ARRAY_BUFFER elemEbo                 ()+		GLBufferData GL_ELEMENT_ARRAY_BUFFER data_   GL_DYNAMIC_DRAW ()++		GLBindBuffer GL_ARRAY_BUFFER elemVbo                 ()+		GLBufferData GL_ARRAY_BUFFER data_   GL_DYNAMIC_DRAW ()++		let newElemVaoVboEbo = (elemVao, elemVbo, elemEbo)++		when setAttrib $ do+			let (si :: GLsizei) = fromIntegral $ sizeOf (error "Internal error: setElemVAOAndBuf: sizeOf accessed its argument!" :: Int32)+			GLVertexAttribIPointer 4 1 GL_INT si 0 ()  -- 4: location of ‘elem’ in the shader.+			GLEnableVertexAttribArray 4 ()++		-- Unbind the VAO.+		GLBindVertexArray 0 ()++		return newElemVaoVboEbo++	-- Now set the new elemvaoandbuf storage, noting if we removed an old+	-- reference so we can free the resource.+	moldElemVaoVboEbo <- monadic -< liftIBIO . flip Atomically id $ do+		moldElemVaoVboEbo <- tryTakeTMVar melemVaoVboEbo+		putTMVar melemVaoVboEbo newElemVaoVboEbo+		return $ moldElemVaoVboEbo++	-- Free an old elemvaobuf if we removed the reference.  Free the resource+	-- without a resource leak.+	() <- monadic -< case moldElemVaoVboEbo of+		Nothing -> pure ()+		Just oldElemVaoVboEbo -> liftIBIO . sdlGL1 sdlh $ do+			let (elemVao, elemVbo, elemEbo) = oldElemVaoVboEbo+			GLDeleteVertexArrays [elemVao] ()+			GLDeleteBuffers      [elemVbo] ()+			GLDeleteBuffers      [elemEbo] ()++	-- Return the new state context with the updated storage.+	returnA -< cxtnp1++	where+		unSingleton [me] = me+		unSingleton _    = error "Internal error: setElemVAOAndBuf expected a single result from GLGenVertexArrays or GLGenBuffers."++-- | Bool: set int32 vertex attrib?+setBallElemVaoVboEbo :: Wire ImmutaballM (GLData, Bool, IBStateContext) IBStateContext+setBallElemVaoVboEbo = proc (data_, setAttrib, cxtn) -> do+	(mballElemVaoVboEbo, cxtnp1) <- requireBallElemVaoVboEbo -< cxtn+	let sdlh = (cxtnp1^.ibContext.ibSDLManagerHandle)++	-- First create a new vao and buf, before exposing its ID to possible+	-- concurrency problems.+	newBallElemVaoVboEbo <- monadic -< liftIBIO . sdlGL1 sdlh $ do+		-- Create a new array and raw buffer of the array.+		elemVao <- unSingleton <$> GLGenVertexArrays 1 id+		elemVbo <- unSingleton <$> GLGenBuffers      1 id+		elemEbo <- unSingleton <$> GLGenBuffers      1 id++		-- Set the data, making it available for upload to the GPU.+		GLBindVertexArray elemVao ()++		GLBindBuffer GL_ELEMENT_ARRAY_BUFFER elemEbo                 ()+		GLBufferData GL_ELEMENT_ARRAY_BUFFER data_   GL_DYNAMIC_DRAW ()++		GLBindBuffer GL_ARRAY_BUFFER elemVbo                 ()+		GLBufferData GL_ARRAY_BUFFER data_   GL_DYNAMIC_DRAW ()++		let newBallElemVaoVboEbo = (elemVao, elemVbo, elemEbo)++		when setAttrib $ do+			let (si :: GLsizei) = fromIntegral $ sizeOf (error "Internal error: setBallElemVAOAndBuf: sizeOf accessed its argument!" :: Int32)+			GLVertexAttribIPointer 4 1 GL_INT si 0 ()  -- 4: location of ‘elem’ in the shader.+			GLEnableVertexAttribArray 4 ()++		-- Unbind the VAO.+		GLBindVertexArray 0 ()++		return newBallElemVaoVboEbo++	-- Now set the new ballelemvaoandbuf storage, noting if we removed an old+	-- reference so we can free the resource.+	moldBallElemVaoVboEbo <- monadic -< liftIBIO . flip Atomically id $ do+		moldBallElemVaoVboEbo <- tryTakeTMVar mballElemVaoVboEbo+		putTMVar mballElemVaoVboEbo newBallElemVaoVboEbo+		return $ moldBallElemVaoVboEbo++	-- Free an old ballelemvaobuf if we removed the reference.  Free the resource+	-- without a resource leak.+	() <- monadic -< case moldBallElemVaoVboEbo of+		Nothing -> pure ()+		Just oldBallElemVaoVboEbo -> liftIBIO . sdlGL1 sdlh $ do+			let (elemVao, elemVbo, elemEbo) = oldBallElemVaoVboEbo+			GLDeleteVertexArrays [elemVao] ()+			GLDeleteBuffers      [elemVbo] ()+			GLDeleteBuffers      [elemEbo] ()++	-- Return the new state context with the updated storage.+	returnA -< cxtnp1++	where+		unSingleton [me] = me+		unSingleton _    = error "Internal error: setBallElemVAOAndBuf expected a single result from GLGenVertexArrays or GLGenBuffers."++getElemVaoVboEbo :: Wire ImmutaballM IBStateContext (Maybe (GLuint, GLuint, GLuint), IBStateContext)+getElemVaoVboEbo = proc cxtn -> do+	(melemVaoVboEbo, cxtnp1) <- requireElemVaoVboEbo -< cxtn+	maelemVaoVboEbo <- monadic -< liftIBIO . flip Atomically id $ tryReadTMVar (melemVaoVboEbo)+	returnA -< (maelemVaoVboEbo, cxtnp1)++getBallElemVaoVboEbo :: Wire ImmutaballM IBStateContext (Maybe (GLuint, GLuint, GLuint), IBStateContext)+getBallElemVaoVboEbo = proc cxtn -> do+	(mballElemVaoVboEbo, cxtnp1) <- requireBallElemVaoVboEbo -< cxtn+	maballElemVaoVboEbo <- monadic -< liftIBIO . flip Atomically id $ tryReadTMVar (mballElemVaoVboEbo)+	returnA -< (maballElemVaoVboEbo, cxtnp1)++-- | Set the currently loaded sol, retrieving the old one.+--+-- The old one can be checked for equality with the new one to determine if+-- we're on a new SOL.+setCurrentlyLoadedSOL :: Wire ImmutaballM (String, IBStateContext) (Maybe String, IBStateContext)+setCurrentlyLoadedSOL = proc (identifyingPath, cxtn) -> do+	(mloadedSol, cxtnp1) <- requireLoadedSolStorage -< cxtn+	moldIdentifyingPath <- monadic -< liftIBIO . flip Atomically id $ do+		moldIdentifyingPath <- tryTakeTMVar mloadedSol+		putTMVar mloadedSol identifyingPath+		return moldIdentifyingPath+	returnA -< (moldIdentifyingPath, cxtnp1)++-- | Row-major.+setTransformation :: Wire ImmutaballM (Mat4 Double, IBStateContext) IBStateContext+setTransformation = proc (_mat@(Mat4 rows), cxtn) -> do+	let matArray = listArray (0, 15) [val' | r <- [rows^.x4, rows^.y4, rows^.z4, rows^.w4], val <- [r^.x4, r^.y4, r^.z4, r^.w4], val' <- return $ toShaderDoubleType val]+	let matArrayGPU = gpuEncodeArray matArray++	cxtnp1 <- setSSBO -< ((shaderSSBOTransformationLocation, matArrayGPU), cxtn)++	returnA -< cxtnp1
+ Immutaball/Share/Utils.hs view
@@ -0,0 +1,211 @@+{-# 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, UndecidableInstances, DerivingVia #-}++module Immutaball.Share.Utils+	(+		Fixed(..), fixed,+		getFixed,+		cata,+		RCompose(..), rcompose,+		getRCompose,+		if',+		deconsBool,+		voidA,+		safeHead,+		safeTail,+		mfix',+		joinMaybeResult,+		chunksOfI,+		chunksOf,+		closeFirstO,+		closeSecondO,+		closeFirstI,+		closeSecondI,+		openFirstO,+		openSecondO,+		openFirstI,+		openSecondI,+		openFirstIO,+		openSecondIO,+		closeFirstIO,+		closeSecondIO,+		withOpenFirstIO,+		withOpenSecondIO,+		concatFirst,+		swap,+		split,+		trueAsIntegralI,+		falseAsIntegralI,+		trueAsIntegral,+		falseAsIntegral,+		deconsMaybe,++		morElse++		--AssumeEOS,+	) where++import Prelude ()+import Immutaball.Prelude++import Control.Arrow+import Control.Monad.Fix+import Data.Functor.Compose+import Data.List+import Data.Maybe++import Control.Lens++-- | See F-algebras and catamorphisms for the idiom.+newtype Fixed f = Fixed {_fixed :: f (Fixed f)}+makeLenses ''Fixed++instance (Eq (f (Fixed f))) => Eq (Fixed f) where+	(Fixed a) == (Fixed b) = a == b+instance (Ord (f (Fixed f))) => Ord (Fixed f) where+	(Fixed a) <= (Fixed b) = a <= b+instance (Show (f (Fixed f))) => Show (Fixed f) where+	show (Fixed a) = show a++getFixed :: Fixed f -> f (Fixed f)+getFixed = (^.fixed)++cata :: (Functor f) => (f a -> a) -> (Fixed f -> a)+cata fAlgebra = fAlgebra . fmap (cata fAlgebra) . getFixed++newtype RCompose f g a = RCompose {_rcompose :: g (f a) }+	deriving (Eq, Ord, Show, Semigroup, Monoid, Enum, Read, Num, Fractional, Real, RealFrac, Bounded)+		via (g (f a))+	deriving (Functor, Applicative, Foldable, {-Traversable, -}Contravariant)+		via (Compose g f)+makeLenses ''RCompose++getRCompose :: RCompose f g a -> g (f a)+getRCompose = (^.rcompose)++if' :: Bool -> a -> a -> a+if' True then_ _  = then_+if' False _ else_ = else_++deconsBool :: r -> r -> Bool -> r+deconsBool withTrue _  (True)  = withTrue+deconsBool _ withFalse (False) = withFalse++voidA :: (Arrow a) => a b c -> a b ()+voidA f = f >>> arr (const ())++safeHead :: [a] -> Maybe a+safeHead []    = Nothing+safeHead (x:_) = Just x++safeTail :: [a] -> Maybe [a]+safeTail []     = Nothing+safeTail (_:xs) = Just xs++mfix' :: (Monad m) => (a -> m a) -> m a+--mfix' f = let ma = ma >>= f in ma+mfix' f = fix $ \me -> me >>= f++joinMaybeResult :: Maybe (a -> Maybe b) -> (a -> Maybe b)+joinMaybeResult mf = \a -> do+	f <- mf+	f a++chunksOfI :: Integer -> [a] -> [[a]]+chunksOfI = chunksOf++chunksOf :: (Integral i) => i -> [a] -> [[a]]+chunksOf _ [] = []+chunksOf n xs = take' n xs : chunksOf n (drop' n xs)+	where (take', drop') = (genericTake, genericDrop)++closeFirstO :: (Arrow a) => a b ((), c) -> a b c+closeFirstO = (>>> arr (\((), c) -> c))++closeSecondO :: (Arrow a) => a b (c, ()) -> a b c+closeSecondO = (>>> arr (\(c, ()) -> c))++closeFirstI :: (Arrow a) => a ((), b) c -> a b c+closeFirstI = (arr ((,) ()) >>>)++closeSecondI :: (Arrow a) => a (b, ()) c -> a b c+closeSecondI = (arr (flip (,) ()) >>>)++openFirstO :: (Arrow a) => a b c -> a b ((), c)+openFirstO = (>>> arr ((,) ()))++openSecondO :: (Arrow a) => a b c -> a b (c, ())+openSecondO = (>>> arr (flip (,) ()))++openFirstI :: (Arrow a) => a b c -> a ((), b) c+openFirstI = (arr (\((), b) -> b) >>>)++openSecondI :: (Arrow a) => a b c -> a (b, ()) c+openSecondI = (arr (\(b, ()) -> b) >>>)++openFirstIO :: (Arrow a) => a b c -> a ((), b) ((), c)+openFirstIO = openFirstO . openFirstI++openSecondIO :: (Arrow a) => a b c -> a (b, ()) (c, ())+openSecondIO = openSecondO . openSecondI++closeFirstIO :: (Arrow a) => a ((), b) ((), c) -> a b c+closeFirstIO = closeFirstI . closeFirstO++closeSecondIO :: (Arrow a) => a (b, ()) (c, ()) -> a b c+closeSecondIO = closeSecondI . closeSecondO++withOpenFirstIO :: (Arrow a) => (a ((), b0) ((), c0) -> a ((), b1) ((), c1)) -> (a b0 c0 -> a b1 c1)+withOpenFirstIO f = closeFirstIO . f . openFirstIO++withOpenSecondIO :: (Arrow a) => (a (b0, ()) (c0, ()) -> a (b1, ()) (c1, ())) -> (a b0 c0 -> a b1 c1)+withOpenSecondIO f = closeSecondIO . f . openSecondIO++concatFirst :: [([a], b)] -> [(a, b)]+concatFirst = concat . map (\(ys, b) -> map (\y -> (y, b)) ys)++swap :: (a, b) -> (b, a)+swap (a, b) = (b, a)++split :: [(a, b)] -> ([a], [b])+split xs = (map fst xs, map snd xs)++trueAsIntegralI :: Integer+trueAsIntegralI = 1++falseAsIntegralI :: Integer+falseAsIntegralI = 0++trueAsIntegral :: (Integral i) => i+trueAsIntegral = fromIntegral $ trueAsIntegralI++falseAsIntegral :: (Integral i) => i+falseAsIntegral = fromIntegral $ falseAsIntegralI++deconsMaybe :: r -> (a -> r) -> Maybe a -> r+deconsMaybe withNothing _ (Nothing) = withNothing+deconsMaybe _ withJust    (Just a)  = withJust a++-- | A convenient way to deconstruct a maybe with a default value.+morElse :: Maybe a -> a -> a+morElse = flip fromMaybe++{-+-- | Empty Eq, Ord, Show instance.+--+-- Useful to hide a component from a record that otherwise implements these+-- instances, e.g. a utility function like ‘spaLumpGetVertexAdjacents’ not+-- essential to the record.  Alternatively, these utility functions could be+-- moved from the record, so that they take an additional input argument of the+-- record.+type AssumeEOS a = a+instance Eq (AssumeEOS a) where _ == _ = True+instance Ord (AssumeEOS a) where _ <= _ = True+instance Show (AssumeEOS a) where show _ = "(AssumeEOS)"+-}
+ Immutaball/Share/Video.hs view
@@ -0,0 +1,423 @@+{-# 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, ExistentialQuantification #-}++module Immutaball.Share.Video+	(+		reverseRowsImageReallySlow,+		reverseRowsImage,++		-- * Shader: high level+		withImmutaballShader,+		sdlCreateImmutaballShader,+		sdlCreateImmutaballShaderWith,++		shaderEnableSceneDataLocation,+		shaderEnableBallDataLocation,+		shaderBallRadiusLocation,+		shaderBallPosLocation,+		shaderBallRotLocation,+		shaderBallNumTrianglesLocation,+		shaderSSBOVertexDataLocation,+		shaderSSBOGeomDataLocation,+		shaderSSBOLumpDataLocation,+		shaderSSBOPathDoublesDataLocation,+		shaderSSBOPathInt32sDataLocation,+		shaderSSBOBodyDataLocation,+		shaderSSBOGcDataLocation,+		shaderSSBOAllGeomPassMvDataLocation,+		shaderSSBOAllGeomPassTexturesDataLocation,+		shaderSSBOAllGeomPassGisDataLocation,+		shaderSSBOGeomPassMvRangesDataLocation,+		shaderSSBOGeomPassTexturesRangesDataLocation,+		shaderSSBOGeomPassGisRangesDataLocation,+		shaderSSBOGeomPassBisDataLocation,+		shaderSSBOTransformationLocation,+		shaderSceneGeomPassIdxLocation,+		shaderSSBOTexcoordsDoubleDataLocation,++		ShaderDoubleType,+		toShaderDoubleType,++		-- * Shader: low level+		ImmutaballShaderHandle(..), ibshVertexShader, ibshFragmentShader,+			ibshProgram, ibshPipeline,+		initImmutaballShader,+		freeImmutaballShader,+		rawInitializeImmutaballShaderContinue,++		-- * MtrlMeta+		MtrlMeta(..),++		-- * Errors+		VideoException(..),+		videoExceptionToException,+		videoExceptionFromException,+		GLErrorVideoException(..),++		-- * Utils+		checkGLErrorsIB,+		glErrType,+		glChecked,+		numToGL_TEXTUREi,+		gpuEncodeArray+	) where++import Prelude ()+import Immutaball.Prelude++import Control.Exception+import Control.Monad+import Data.Bits+import Data.List+import Data.Typeable (cast)+import Data.Word++import Control.Concurrent.STM.TMVar+import Control.Lens+import qualified Data.ByteString as BS+--import qualified Data.ByteString.Lazy as BL+import qualified Data.Map as M+import Graphics.GL.Compatibility45+--import Graphics.GL.Core45+import Graphics.GL.Types++import Immutaball.Share.Math+import Immutaball.Share.ImmutaballIO+import Immutaball.Share.ImmutaballIO.BasicIO+import Immutaball.Share.ImmutaballIO.GLIO+import Immutaball.Share.SDLManager+import Immutaball.Share.Utils+import Immutaball.Share.Video.LowLevel+import Immutaball.Share.Video.Shaders++-- | Replaced by a newer 'reverseRowsImage' that performs better.+reverseRowsImageReallySlow :: (WidthHeightI, BS.ByteString) -> BS.ByteString+reverseRowsImageReallySlow ((w, _h), image) = glImage+	where+		glImage = BS.pack glBytes+		bytes :: [Word8]+		bytes = BS.unpack image+		glBytes :: [Word8]+		glBytes = concat glRows+		glRows :: [[Word8]]+		glRows = reverse rows+		rows :: [[Word8]]+		rows = withRemaining bytes+		withRemaining :: [Word8] -> [[Word8]]+		withRemaining [] = []+		withRemaining xs = genericTake row xs : withRemaining (genericDrop row xs)+		row = 4 * w++-- Moved to avoid Template Haskell errors.++data ImmutaballShaderHandle = ImmutaballShaderHandle {+	_ibshVertexShader   :: GLuint,+	_ibshFragmentShader :: GLuint,+	_ibshProgram        :: GLuint,+	_ibshPipeline       :: GLuint+}+makeLenses ''ImmutaballShaderHandle++-- * Shader: high level++-- | Directly initialize the shader, attaching the lifetime to the caller; does+-- not asynchronously attach the lifetime to the SDL manager thread, which can be done with+-- 'sdlCreateImmutaballShader'.+withImmutaballShader :: SDLManagerHandle -> (ImmutaballShaderHandle -> ImmutaballIOF me) -> ImmutaballIOF me+withImmutaballShader sdlMgr withShader = do+	shader <- initImmutaballShader sdlMgr+	me <- withShader shader+	freeImmutaballShader sdlMgr shader+	return me++-- | Use the SDL Manager thread to manage the immutaball shader resource.+--+-- When the SDL Manager thread exits, it will deallocate the resource.+--+-- The TMVar is set with the resource once the initializer is done.+--+-- The SDLManager initializes this resource concurrently, so it does not block+-- the SDLManager thread.+sdlCreateImmutaballShader :: SDLManagerHandle -> ImmutaballIOF (TMVar ImmutaballShaderHandle)+sdlCreateImmutaballShader sdlMgr =+	JoinIBIOF .+	Atomically (newEmptyTMVar) $ \to_ ->+	attachLifetime sdlMgr (initImmutaballShader sdlMgr) (freeImmutaballShader sdlMgr) to_ to_++-- | 'sdlCreateImmutaballShader' variant that uses a supplied TMVar for storage.+sdlCreateImmutaballShaderWith :: SDLManagerHandle -> TMVar ImmutaballShaderHandle -> ImmutaballIOF ()+sdlCreateImmutaballShaderWith sdlMgr to_ =+	attachLifetime sdlMgr (initImmutaballShader sdlMgr) (freeImmutaballShader sdlMgr) to_ ()++shaderEnableSceneDataLocation :: GLint+shaderEnableSceneDataLocation = fromIntegral (16 :: Integer)++shaderEnableBallDataLocation :: GLint+shaderEnableBallDataLocation = fromIntegral (34 :: Integer)++shaderBallRadiusLocation :: GLint+shaderBallRadiusLocation = fromIntegral (35 :: Integer)++shaderBallNumTrianglesLocation :: GLint+shaderBallNumTrianglesLocation = fromIntegral (36 :: Integer)++shaderBallPosLocation :: GLint+shaderBallPosLocation = fromIntegral (37 :: Integer)++shaderBallRotLocation :: GLint+shaderBallRotLocation = fromIntegral (38 :: Integer)++shaderSSBOVertexDataLocation :: GLuint+shaderSSBOVertexDataLocation = fromIntegral (17 :: Integer)++shaderSSBOGeomDataLocation :: GLuint+shaderSSBOGeomDataLocation = fromIntegral (18 :: Integer)++shaderSSBOLumpDataLocation :: GLuint+shaderSSBOLumpDataLocation = fromIntegral (19 :: Integer)++shaderSSBOPathDoublesDataLocation :: GLuint+shaderSSBOPathDoublesDataLocation = fromIntegral (20 :: Integer)++shaderSSBOPathInt32sDataLocation :: GLuint+shaderSSBOPathInt32sDataLocation = fromIntegral (21 :: Integer)++shaderSSBOBodyDataLocation :: GLuint+shaderSSBOBodyDataLocation = fromIntegral (22 :: Integer)++shaderSSBOGcDataLocation :: GLuint+shaderSSBOGcDataLocation = fromIntegral (23 :: Integer)++shaderSSBOAllGeomPassMvDataLocation :: GLuint+shaderSSBOAllGeomPassMvDataLocation = fromIntegral (24 :: Integer)++shaderSSBOAllGeomPassTexturesDataLocation :: GLuint+shaderSSBOAllGeomPassTexturesDataLocation = fromIntegral (25 :: Integer)++shaderSSBOAllGeomPassGisDataLocation :: GLuint+shaderSSBOAllGeomPassGisDataLocation = fromIntegral (26 :: Integer)++shaderSSBOGeomPassMvRangesDataLocation :: GLuint+shaderSSBOGeomPassMvRangesDataLocation = fromIntegral (27 :: Integer)++shaderSSBOGeomPassTexturesRangesDataLocation :: GLuint+shaderSSBOGeomPassTexturesRangesDataLocation = fromIntegral (28 :: Integer)++shaderSSBOGeomPassGisRangesDataLocation :: GLuint+shaderSSBOGeomPassGisRangesDataLocation = fromIntegral (29 :: Integer)++shaderSSBOGeomPassBisDataLocation :: GLuint+shaderSSBOGeomPassBisDataLocation = fromIntegral (30 :: Integer)++shaderSSBOTransformationLocation :: GLuint+shaderSSBOTransformationLocation = fromIntegral (31 :: Integer)++shaderSSBOTexcoordsDoubleDataLocation :: GLuint+shaderSSBOTexcoordsDoubleDataLocation = fromIntegral (32 :: Integer)++shaderSceneGeomPassIdxLocation :: GLint+shaderSceneGeomPassIdxLocation = fromIntegral (33 :: Integer)++-- | Whether the shaders use doubles or floats for the SSBOs.+--type ShaderDoubleType = Double+type ShaderDoubleType = Float++-- | Convert Doubles to the Double type the shaders use for SSBOs.+toShaderDoubleType :: Double -> ShaderDoubleType+--toShaderDoubleType = id+toShaderDoubleType = realToFrac++-- * Shader: low level++-- ImmutaballShaderHandle moved to avoid Template Haskell errors.++-- | Allocate an immutaball shader.+--+-- (The SDLManager runs the initializer concurrently.  If it didn't, it would+-- deadlock because we also dispatch to the SDL Manager to run commands.)+initImmutaballShader :: SDLManagerHandle -> ImmutaballIOF ImmutaballShaderHandle+initImmutaballShader sdlMgr =+	JoinIBIOF .+	Atomically (newEmptyTMVar) $ \mibsh ->+	(>>= \() -> Atomically (readTMVar mibsh) id) . sdlIBIO sdlMgr $ do+		-- We're the only shader manager in this application, so we don't need+		-- to worry about exclusion here currently.  But regardless, exclusion+		-- is already present because sdlMgr blocks if we, the caller, don't+		-- fork a thread for a general IBIO dispatch.+		vertexShader_   <- (BasicIBIOF . GLIO $ GLCreateShader GL_VERTEX_SHADER id  ) <* checkGLErrorsIB+		fragmentShader_ <- (BasicIBIOF . GLIO $ GLCreateShader GL_FRAGMENT_SHADER id) <* checkGLErrorsIB+		program         <- (BasicIBIOF . GLIO $ GLCreateProgram id                  ) <* checkGLErrorsIB+		mpipeline       <- (BasicIBIOF . GLIO $ GLGenProgramPipelines 1 id          ) <* checkGLErrorsIB+		let pipeline = unSingleton mpipeline+		let ibsh = ImmutaballShaderHandle {+			_ibshVertexShader   = vertexShader_,+			_ibshFragmentShader = fragmentShader_,+			_ibshProgram        = program,+			_ibshPipeline       = pipeline+		}+		warnIf (vertexShader_ == 0 && fragmentShader_ == 0) $ "Warning: initImmutaballShader: vertex and fragment shaders both have names 0!"+		-- Don't write it until we finish initialization, to keep things synchronized.+		rawInitializeImmutaballShaderContinue ibsh+		Atomically (writeTMVar mibsh ibsh) id+	where+		unSingleton [me] = me+		unSingleton _    = error "Internal error: initImmutaballShader expected a single result from GLGenProgramPipelines."+		warnIf :: Bool -> String -> ImmutaballIOF ()+		warnIf condition msg = do+			() <- if' (not condition) (pure ()) . BasicIBIOF $ PutStrLn msg ()+			return ()++-- | Deallocate an immutaball shader.+freeImmutaballShader :: SDLManagerHandle -> ImmutaballShaderHandle -> ImmutaballIOF ()+freeImmutaballShader sdlMgr ibsh = do+	let sdlGL1' = sdlGL1 sdlMgr+	sdlGL1' $ do+		GLDeleteProgramPipelines [(ibsh^.ibshPipeline)] ()+		GLDeleteProgram (ibsh^.ibshProgram) ()+		GLDeleteShader (ibsh^.ibshFragmentShader) ()+		GLDeleteShader (ibsh^.ibshVertexShader) ()++-- | (Note: we are already in the SDL Manager thread.)+rawInitializeImmutaballShaderContinue :: ImmutaballShaderHandle -> ImmutaballIOF ()+rawInitializeImmutaballShaderContinue ibsh = do+	glChecked $ GLShaderSource (ibsh^.ibshVertexShader) [vertexShader] ()+	glChecked $ GLShaderSource (ibsh^.ibshFragmentShader) [fragmentShader] ()++	glChecked $ GLCompileShader (ibsh^.ibshVertexShader) ()+	successV <- ((/= 0) <$>) . glChecked $ GLGetShaderiv (ibsh^.ibshVertexShader) GL_COMPILE_STATUS id+	when (not successV) $ do+		compileError <- BasicIBIOF . GLIO $ GLGetShaderInfoLog (ibsh^.ibshVertexShader) id+		() <- BasicIBIOF $ PutStrLn ("Error: the vertex shader failed to compile!  OpenGL error: " ++ compileError) ()+		checkGLErrorsIB+		() <- BasicIBIOF $ ExitFailureBasicIOF+		return ()++	glChecked $ GLCompileShader (ibsh^.ibshFragmentShader) ()+	successF <- ((/= 0) <$>) . glChecked $ GLGetShaderiv (ibsh^.ibshFragmentShader) GL_COMPILE_STATUS id+	when (not successF) $ do+		compileError <- glChecked $ GLGetShaderInfoLog (ibsh^.ibshFragmentShader) id+		() <- BasicIBIOF $ PutStrLn ("Error: the fragment shader failed to compile!  OpenGL error: " ++ compileError) ()+		checkGLErrorsIB+		() <- BasicIBIOF $ ExitFailureBasicIOF+		return ()++	when setupProgramPipeline $ do+		glChecked $ GLProgramParameteri (ibsh^.ibshProgram) GL_PROGRAM_SEPARABLE GL_TRUE ()++	glChecked $ GLAttachShader (ibsh^.ibshProgram) (ibsh^.ibshVertexShader) ()+	glChecked $ GLAttachShader (ibsh^.ibshProgram) (ibsh^.ibshFragmentShader) ()+	glChecked $ GLLinkProgram (ibsh^.ibshProgram) ()++	successL <- ((/= 0) <$>) . glChecked $ GLGetProgramiv (ibsh^.ibshProgram) GL_LINK_STATUS id+	when (not successL) $ do+		linkError <- BasicIBIOF . GLIO $ GLGetProgramInfoLog (ibsh^.ibshProgram) id+		() <- BasicIBIOF $ PutStrLn ("Error: the OpenGL GLSL shaders failed to link!  OpenGL error: " ++ linkError) ()+		checkGLErrorsIB+		() <- BasicIBIOF $ ExitFailureBasicIOF+		return ()++	when (not useProgramPipeline) $ do+		glChecked $ GLUseProgram (ibsh^.ibshProgram) ()+	when setupProgramPipeline $ do+		let stages = foldr (.|.) 0 $+			[+				GL_VERTEX_SHADER_BIT,+				GL_FRAGMENT_SHADER_BIT+			]+		-- TODO FIXME: when 'useProgramPipeline' is True, this fails with GL_INVALID_OPERATION for me.+		-- We're not using it anyway, though, so this isn't particularly urgent.+		glChecked $ GLUseProgramStages (ibsh^.ibshPipeline) stages (ibsh^.ibshProgram) ()+	when useProgramPipeline $ do+		glChecked $ GLUseProgram 0 ()+		glChecked $ GLBindProgramPipeline (ibsh^.ibshPipeline) ()+	where+		setupProgramPipeline :: Bool+		setupProgramPipeline = useProgramPipeline+		-- We only need the program.+		useProgramPipeline :: Bool+		useProgramPipeline = False++-- * MtrlMeta++-- | TODO:+data MtrlMeta = MtrlMeta {+}+	deriving (Eq, Ord, Show)+--makeLenses ''MtrlMeta++-- * Errors++data VideoException = forall e. Exception e => VideoException e+instance Show VideoException where+	show (VideoException e) = show e+instance Exception VideoException+videoExceptionToException :: Exception e => e -> SomeException+videoExceptionToException = toException . VideoException+videoExceptionFromException :: Exception e => SomeException -> Maybe e+videoExceptionFromException x = do+	VideoException a <- fromException x+	cast a++data GLErrorVideoException = GLErrorVideoException String+instance Exception GLErrorVideoException where+	toException = videoExceptionToException+	fromException = videoExceptionFromException+instance Show GLErrorVideoException where+	show (GLErrorVideoException msg) = msg++-- * Utils++checkGLErrorsIB :: ImmutaballIOF ()+checkGLErrorsIB = do+	error_ <- BasicIBIOF . GLIO $ GLGetError id+	case error_ of+		GL_NO_ERROR -> return ()+		err -> do+			let msg = "Error: an OpenGL error occurred (" ++ show err ++ "): " ++ glErrType err+			() <- BasicIBIOF $ PutStrLn msg ()+			() <- ThrowIO (GLErrorVideoException msg)+			() <- BasicIBIOF $ ExitFailureBasicIOF+			return ()++glErrType :: GLenum -> String+glErrType GL_NO_ERROR                      = "GL_NO_ERROR"+glErrType GL_INVALID_ENUM                  = "GL_INVALID_ENUM"+glErrType GL_INVALID_VALUE                 = "GL_INVALID_VALUE"+glErrType GL_INVALID_OPERATION             = "GL_INVALID_OPERATION"+glErrType GL_INVALID_FRAMEBUFFER_OPERATION = "GL_INVALID_FRAMEBUFFER_OPERATION"+glErrType GL_OUT_OF_MEMORY                 = "GL_OUT_OF_MEMORY"+glErrType GL_STACK_OVERFLOW                = "GL_STACK_OVERFLOW"+glErrType GL_STACK_UNDERFLOW               = "GL_STACK_UNDERLOW"+glErrType _                                = "unknown error type"++glChecked :: GLIOF me -> ImmutaballIOF me+glChecked m = (BasicIBIOF . GLIO $ m) <* checkGLErrorsIB++numToGL_TEXTUREi :: M.Map Integer GLenum+numToGL_TEXTUREi = M.fromList $+	[+		(0,  GL_TEXTURE0),+		(1,  GL_TEXTURE1),+		(2,  GL_TEXTURE2),+		(3,  GL_TEXTURE3),+		(4,  GL_TEXTURE4),+		(5,  GL_TEXTURE5),+		(6,  GL_TEXTURE6),+		(7,  GL_TEXTURE7),+		(8,  GL_TEXTURE8),+		(9,  GL_TEXTURE9),+		(10, GL_TEXTURE10),+		(11, GL_TEXTURE11),+		(12, GL_TEXTURE12),+		(13, GL_TEXTURE13),+		(14, GL_TEXTURE14),+		(15, GL_TEXTURE15)+	]++makeLenses ''MtrlMeta
+ Immutaball/Share/Video/LowLevel.hs view
@@ -0,0 +1,136 @@+{-# 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 #-}++-- Video/LowLevel.hs.++{-# LANGUAGE Haskell2010 #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | gpuEncodeArray and reverseRowsImage.+module Immutaball.Share.Video.LowLevel+	(+		gpuEncodeArray,+		reverseRowsImage,+		reverseRowsImageBuilderRows,+		reverseRowsImageBuilderBytes,+		reverseRowsImageLowLevel+	) where++-- Prelude imports.+import Prelude ()+import Immutaball.Prelude++-- base imports.+import Control.Arrow+import Control.Monad+import qualified Data.Array.Unsafe+import Data.Function hiding (id, (.))+import Data.Int+import Data.Word+import Foreign.C.Types+import Foreign.Marshal+import Foreign.Ptr+import Foreign.Storable++-- external imports.+import Data.Array.IArray+import Data.Array.Storable+import qualified Data.ByteString as BS+import qualified Data.ByteString.Builder as BB+--import qualified Data.ByteString.Builder.Extra as BB+import qualified Data.ByteString.Lazy as BL++-- internal (local) imports.+import Immutaball.Share.ImmutaballIO.GLIO+import Immutaball.Share.Math+import Immutaball.Share.Utils++-- Low-level imports.+import qualified Data.ByteString.Unsafe as UnsafeBS+import System.IO.Unsafe (unsafePerformIO)++gpuEncodeArray :: forall a. (Storable a) => Array Int32 a -> GLData+gpuEncodeArray array_ = unsafePerformIO $ do+	(storableArray :: StorableArray Int32 a) <- Data.Array.Unsafe.unsafeThaw array_+	bs <- withStorableArray storableArray $ \(ptr :: Ptr a) -> do+		let (bsPtr :: Ptr CChar) = castPtr ptr+		let (numElems :: Int) = rangeSize . bounds $ array_+		let (bsLen :: Int) = numElems * sizeOf ((array_ ! 0)  :: a)+		bs <- BS.packCStringLen (bsPtr, bsLen)+		return bs+	let data_ = bsToGLData bs+	return $ data_++reverseRowsImage :: (WidthHeightI, BS.ByteString) -> BS.ByteString+--reverseRowsImage = reverseRowsImageLowLevel+--reverseRowsImage = reverseRowsImageBuilderBytes+reverseRowsImage = reverseRowsImageBuilderRows++-- This is much better.  And safe!+reverseRowsImageBuilderRows :: (WidthHeightI, BS.ByteString) -> BS.ByteString+reverseRowsImageBuilderRows ((w, h), image)+	| BS.length image <= 0 = image+	| otherwise = BL.toStrict . BB.toLazyByteString $+		flip fix 0 $ \withRow row ->+			if' (row >= h') mempty $+			(BB.byteString . BS.take (w'*4) . BS.drop (((h'-1)-row)*w'*4) $ image) <> (withRow (row+1))+	where+		w', h' :: Int+		(w', h') = join (***) fromIntegral (w, h)++-- This is still noticeably slower than reverseRowsImageLowLevel.+reverseRowsImageBuilderBytes :: (WidthHeightI, BS.ByteString) -> BS.ByteString+reverseRowsImageBuilderBytes ((w, h), image)+	| BS.length image <= 0 = image+	| otherwise = BL.toStrict . BB.toLazyByteString $+	-- | otherwise = BL.toStrict . BB.toLazyByteStringWith (BB.safeStrategy chunkSize chunkSize) BL.empty $+		flip fix 0 $ \withRow row ->+			if' (row >= h') mempty $+			flip fix 0 $ \withCol col ->+				if' (col >= w') (withRow (row+1)) $+				flip fix 0 $ \withComponent component ->+					if' (component >= 4) (withCol (col+1)) $+					let idx = ((h'-1)-row)*w'*4 + col*4 + component in+					if' (idx >= BS.length image) mempty $+					--(BB.word8 $ image `UnsafeBS.unsafeIndex` idx) <> (withComponent (component+1))  -- This doesn't seem to be a major improvement on the core performance issue.  Keep it to the safe API.+					(BB.word8 $ image `BS.index` idx) <> (withComponent (component+1))+	where+		w', h' :: Int+		(w', h') = join (***) fromIntegral (w, h)+		--chunkSize :: Int+		--chunkSize = 2^(20 :: Int)++-- | The old version was really slow.+--+-- Use unsafe lower-level functions to manually implement a faster version,+-- given the limitations of the safe bytestring interface provided along with+-- the low-level implementation of it.+--+-- But now we have a safe _and_ faster version that uses bytestring builders; see 'reverseRowsImageBuilderRows'.+reverseRowsImageLowLevel :: (WidthHeightI, BS.ByteString) -> BS.ByteString+reverseRowsImageLowLevel ((w, h), image)+	| BS.length image <= 0 = image+	| otherwise = unsafePerformIO $ do+		-- Unsafe optimization to avoid a copy: use unsafeUseAsCStringLen with the promise we won't mutate the data.+		--useAsCStringLen image $ \(ptr, len) -> do+		UnsafeBS.unsafeUseAsCStringLen image $ \(ptr, len_) -> do+			let len = max 1 $ len_+			let (imageBufferI :: Ptr Word8) = castPtr ptr+			(imageBufferO :: Ptr Word8) <- mallocArray len+			flip fix 0 $ \withRow rowI -> let rowOffsetI = rowI * 4*w' in if' (rowOffsetI >= len_) (return ()) $ do+				let rowO = (h' - 1) - rowI; rowOffsetO = rowO * 4*w'+				flip fix 0 $ \withCol colI -> let colOffsetI = 4*colI in if' (rowOffsetI + colOffsetI + 3 >= len_) (return ()) $ do+					if' (colI >= w') (withRow (rowI+1)) $ do+						let colO = colI; colOffsetO = 4*colO+						peek (imageBufferI `plusPtr'` (rowOffsetI + colOffsetI + 0)) >>= poke (imageBufferO `plusPtr'` (rowOffsetO + colOffsetO + 0))+						peek (imageBufferI `plusPtr'` (rowOffsetI + colOffsetI + 1)) >>= poke (imageBufferO `plusPtr'` (rowOffsetO + colOffsetO + 1))+						peek (imageBufferI `plusPtr'` (rowOffsetI + colOffsetI + 2)) >>= poke (imageBufferO `plusPtr'` (rowOffsetO + colOffsetO + 2))+						peek (imageBufferI `plusPtr'` (rowOffsetI + colOffsetI + 3)) >>= poke (imageBufferO `plusPtr'` (rowOffsetO + colOffsetO + 3))+						withCol (colI+1)+			UnsafeBS.unsafePackMallocCStringLen $ (castPtr imageBufferO, len)+	where+		w', h' :: Int+		(w', h') = join (***) fromIntegral (w, h)+		plusPtr' :: Ptr a -> Int -> Ptr a+		plusPtr' = plusPtr
+ Immutaball/Share/Video/Shaders.hs view
@@ -0,0 +1,395 @@+{-# 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 #-}++module Immutaball.Share.Video.Shaders+	(+		vertexShader,+		fragmentShader+	) where++import Prelude ()+import Immutaball.Prelude++vertexShader :: String+vertexShader = unlines $+	[+		"#version 450 core",+		"",+		"layout(location = 0) in vec3 position;",+		"layout(location = 1) in vec4 modulateColor;",+		"layout(location = 2) in vec2 texCoords;",+		"layout(location = 3) in int  texLayer;",+		"layout(location = 4) in int  elem;",+		"",+		"out      vec4 vertexModulateColor;",+		"out      vec2 vertexTexCoords;",+		"out flat int  vertexTexLayer;",+		"out flat int  doDiscard;",+		"",+		"// 3 modes: drawing GUI (false, false) drawing scene / level (true, false), and drawing ball (false, true)",+		"layout(location = 16) uniform int   enableSceneData;",+		"layout(location = 34) uniform int   enableBallData;",+		"layout(location = 35) uniform float ballRadius;",+		"layout(location = 36) uniform int   ballNumTriangles;",+		"layout(location = 37) uniform vec3  ballPos;",+		"layout(location = 38) uniform vec3  ballRot;",+		"",+		"// 16 SOL render analysis arrays (scene data), locations 17-32",+		"layout(std430, binding = 17) buffer layoutSSBOVertexData {",+		--"\tdouble ssboVertexData[];",+		"\t float ssboVertexData[];",+		"};",+		"layout(std430, binding = 18) buffer layoutSSBOGeomData {",+		"\tint ssboGeomData[];",+		"};",+		"layout(std430, binding = 19) buffer layoutSSBOLumpData {",+		"\tint ssboLumpData[];",+		"};",+		"layout(std430, binding = 20) buffer layoutSSBOPathDoublesData {",+		--"\tdouble ssboPathDoublesData[];",+		"\t float ssboPathDoublesData[];",+		"};",+		"layout(std430, binding = 21) buffer layoutSSBOPathInt32sData {",+		"\tint ssboPathInt32sData[];",+		"};",+		"layout(std430, binding = 22) buffer layoutSSBOBodyData {",+		"\tint ssboBodyData[];",+		"};",+		"layout(std430, binding = 23) buffer layoutSSBOGcData {",+		"\tint ssboGcData[];",+		"};",+		"layout(std430, binding = 24) buffer layoutSSBOAllGeomPassMvData {",+		"\tint ssboAllGeomPassMvData[];",+		"};",+		"layout(std430, binding = 25) buffer layoutSSBOAllGeomPassTexturesData {",+		"\tint ssboAllGeomPassTexturesData[];",+		"};",+		"layout(std430, binding = 26) buffer layoutSSBOAllGeomPassGisData {",+		"\tint ssboAllGeomPassGisData[];",+		"};",+		"layout(std430, binding = 27) buffer layoutSSBOGeomPassMvRangesData {",+		"\tint ssboGeomPassMvRangesData[];",+		"};",+		"layout(std430, binding = 28) buffer layoutSSBOGeomPassTexturesRangesData {",+		"\tint ssboGeomPassTexturesRangesData[];",+		"};",+		"layout(std430, binding = 29) buffer layoutSSBOGeomPassGisRangesData {",+		"\tint ssboGeomPassGisRangesData[];",+		"};",+		"layout(std430, binding = 30) buffer layoutSSBOGeomPassBisData {",+		"\tint ssboGeomPassBisData[];",+		"};",+		"",+		"layout(std430, binding = 31) buffer layoutSSBOTransformationData {",+		--"\tdouble ssboTransformationData[];",+		"\t float ssboTransformationData[];",+		"};",+		"",+		"layout(std430, binding = 32) buffer layoutSSBOTexcoordsDoubleData {",+		--"\tdouble ssboTexcoordsDoubleData[];",+		"\t float ssboTexcoordsDoubleData[];",+		"};",+		"",+		"layout(location = 33) uniform int sceneGeomPassIdx;",+		"",+		"// Required for linking with GL_PROGRAM_SEPARABLE apparently.",+		"out gl_PerVertex {",+		"\tvec4  gl_Position;",+		"\tfloat gl_PointSize;",+		"\tfloat gl_ClipDistance[];",+		"};",+		"",+		--"vec4 rowMajorMatMulVecdf(double mat[16], vec4 untransformed) {",+		"vec4 rowMajorMatMulVecdf( float mat[16], vec4 untransformed) {",+		"\tfloat transformedx = float(mat[0]) * untransformed.x + float(mat[1]) * untransformed.y + float(mat[2]) * untransformed.z + float(mat[3]) * untransformed.w;",+		"\tfloat transformedy = float(mat[4]) * untransformed.x + float(mat[5]) * untransformed.y + float(mat[6]) * untransformed.z + float(mat[7]) * untransformed.w;",+		"\tfloat transformedz = float(mat[8]) * untransformed.x + float(mat[9]) * untransformed.y + float(mat[10]) * untransformed.z + float(mat[11]) * untransformed.w;",+		"\tfloat transformedw = float(mat[12]) * untransformed.x + float(mat[13]) * untransformed.y + float(mat[14]) * untransformed.z + float(mat[15]) * untransformed.w;",+		"\treturn vec4(transformedx, transformedy, transformedz, transformedw);",+		"}",+		"",+		"vec4 transfMul(vec4 untransformed) {",+		"\t//vec4 transformed = rowMajorMatMulVecdf(ssboTransformationData, untransformed);",+		"\tfloat transformedx = float(ssboTransformationData[0]) * untransformed.x + float(ssboTransformationData[1]) * untransformed.y + float(ssboTransformationData[2]) * untransformed.z + float(ssboTransformationData[3]) * untransformed.w;",+		"\tfloat transformedy = float(ssboTransformationData[4]) * untransformed.x + float(ssboTransformationData[5]) * untransformed.y + float(ssboTransformationData[6]) * untransformed.z + float(ssboTransformationData[7]) * untransformed.w;",+		"\tfloat transformedz = float(ssboTransformationData[8]) * untransformed.x + float(ssboTransformationData[9]) * untransformed.y + float(ssboTransformationData[10]) * untransformed.z + float(ssboTransformationData[11]) * untransformed.w;",+		"\tfloat transformedw = float(ssboTransformationData[12]) * untransformed.x + float(ssboTransformationData[13]) * untransformed.y + float(ssboTransformationData[14]) * untransformed.z + float(ssboTransformationData[15]) * untransformed.w;",+		"\tvec4 transformed = vec4(transformedx, transformedy, transformedz, transformedw);",+		"\treturn transformed;",+		"}",+		"",+		"void mainGUI() {",+		"\tgl_Position = vec4(position, 1.0);",+		"\tvertexModulateColor = modulateColor;",+		"\tvertexTexCoords = texCoords;",+		"\tvertexTexLayer = texLayer;",+		"\tdoDiscard = 0;",+		"}",+		"",+		"void mainScene() {",+		"\t// Render elem ‘elem’ in the geom pass ‘sceneGeomPassIdx’.",+		"\tint geomPassTexture0 = ssboGeomPassTexturesRangesData[2*sceneGeomPassIdx+0];",+		"\tint geomPassTexturec = ssboGeomPassTexturesRangesData[2*sceneGeomPassIdx+1];",+		"\tint geomPassGi0      = ssboGeomPassGisRangesData[2*sceneGeomPassIdx+0];",+		"\tint geomPassGic      = ssboGeomPassGisRangesData[2*sceneGeomPassIdx+1];",+		"",+		"\tint whichElem = elem / 3;",+		"\tint whichVert = elem % 3;",+		"",+		"\tint texture = ssboAllGeomPassTexturesData[( geomPassTexture0 + whichElem )];",+		"\tint gi      = ssboAllGeomPassGisData[(      geomPassGi0      + whichElem )];",+		"",+		"\tint vi = ssboGeomData[9*gi+0];",+		"\tint vj = ssboGeomData[9*gi+1];",+		"\tint vk = ssboGeomData[9*gi+2];",+		"\tint ti = ssboGeomData[9*gi+3];",+		"\tint tj = ssboGeomData[9*gi+4];",+		"\tint tk = ssboGeomData[9*gi+5];",+		"\tint si = ssboGeomData[9*gi+6];",+		"\tint sj = ssboGeomData[9*gi+7];",+		"\tint sk = ssboGeomData[9*gi+8];",+		"",+		"\tint v = ssboGeomData[9*gi+0+(whichVert)];",+		"\tint t = ssboGeomData[9*gi+3+(whichVert)];",+		"\tint s = ssboGeomData[9*gi+6+(whichVert)];",+		"",+		"\t// Texture coords.",+		--"\tdouble texs  = ssboTexcoordsDoubleData[2*t+0];",+		--"\tdouble text  = ssboTexcoordsDoubleData[2*t+1];",+		"\t float texs  = ssboTexcoordsDoubleData[2*t+0];",+		"\t float text  = ssboTexcoordsDoubleData[2*t+1];",+		"\tfloat  texsf = float(texs);",+		"\tfloat  textf = float(text);",+		"",+		--"\tdouble vx = ssboVertexData[3*v+0];",+		--"\tdouble vy = ssboVertexData[3*v+1];",+		--"\tdouble vz = ssboVertexData[3*v+2];",+		"\t float vx = ssboVertexData[3*v+0];",+		"\t float vy = ssboVertexData[3*v+1];",+		"\t float vz = ssboVertexData[3*v+2];",+		"\tfloat vxf = float(vx);",+		"\tfloat vyf = float(vy);",+		"\tfloat vzf = float(vz);",+		"\tvec3 vfbase = vec3(vxf, vyf, vzf);",+		"\tvec4 vfuntransformed = vec4(vfbase, 1.0);",+		"\tvec4 vf = transfMul(vfuntransformed);",+		"\tvec4 out_gl_Position = vf;",+		-- TODO DEBUG+		--"\tout_gl_Position = (!(gi > 50)) ? vf : (whichVert==0?vec4(vf.x,0.0,0.0,1.0):(whichVert==1?vec4(0.0,1.0,0.0,1.0):vec4(1.0,1.0,0.0,1.0)));",+		"",+		"\tvec4 out_modulateColor = vec4(1.0, 1.0, 1.0, 1.0);",+		"",+		"\tvec2 out_texCoords = vec2(texsf, textf);",+		"",+		"\tint out_texLayer = texture;",+		"",+		"\tgl_Position = out_gl_Position;",+		--"\tgl_Position = whichVert==0?vec4(vf.x,0.0,0.0,1.0):(whichVert==1?vec4(0.0,1.0,0.0,1.0):vec4(1.0,1.0,0.0,1.0));",  -- TODO DEBUG+		--"\tgl_Position = vfuntransformed;",  -- TODO DEBUG+		--"\tgl_Position = (sceneGeomPassIdx%3)==0?vec4(0.0,0.0,0.0,1.0):((sceneGeomPassIdx%3)==1?vec4(0.0,1.0,0.0,1.0):vec4(1.0,1.0,0.0,1.0));",  -- TODO DEBUG+		"\tvertexModulateColor = out_modulateColor;",+		"\tvertexTexCoords = out_texCoords;",+		"\tvertexTexLayer = out_texLayer;",+		"\tdoDiscard = 0;",+		"}",+		"",+		"// glDrawArrays is called with ballNumTriangles * 3, and elem is vertex to render.",+		"void mainBall() {",+		"\tint whichElem = elem / 3;",+		"\tint whichVert = elem % 3;  // Which of the 3 vertices of the triangle?",+		"",+		"\t// Now partition into squares and then triangles; consecutive",+		"\t// triangle pairs represent which of the 2 triangles of the square",+		"\t// to use.",+		--"\tint whichDivision = whichElem / 2;",+		--"\tint whichTriPart = whichElem % 2;  // First triangle or second triangle of the square?",+		"\tint whichSquare = whichElem / 2;",+		"\tint whichSquareTri = whichElem % 2;  // First triangle or second triangle of the square?",+		"",+		"\t// Make a circle on xy plane, then repeat with the xy plane tilted",+		"\t// until the tilt makes a full circle.",+		"\t// The number of circles equals the number of tilts.",+		"\tint squaresInOneCircle = int(round(sqrt(float(ballNumTriangles / 2)) - 0.6));",+		"\tint numTilts           = squaresInOneCircle;",+		"",+		"\t// 4 points for 2 triangles: inner p0, inner p1, outer p0, outer p1",+		"\t// (outer is 1 tilt further than inner, p1 is one sample in the circle",+		"\t// further than p0).",+		"\tint whichSquarePoint = whichVert + whichSquareTri;",+		"\tbool sp0 = whichSquarePoint == 0;",+		"\tbool sp1 = whichSquarePoint == 1;",+		"\tbool sp2 = whichSquarePoint == 2;",+		"\tbool sp3 = whichSquarePoint == 3;",+		"",+		"\tint onNextSample = (sp1 || sp3) ? 1 : 0;  // Is this point p1 and not p0?  (Advance the sample / partition index within the tilt by 1.)",+		"\tint onNextTilt   = (sp2 || sp3) ? 1 : 0;  // Is this point on the next tilt, rather than the current?",+		"",+		"\tconst float pi  = radians(180);",+		"\tconst float tau = radians(360);",+		"",+		"\tint whichCircleSample  = whichSquare % numTilts           + onNextSample;",+		"\tint whichTilt          = whichSquare / squaresInOneCircle + onNextTilt;",+		"\tfloat circleSample     = float(whichCircleSample) / float(squaresInOneCircle);  // 0.0 represents the start of the circle; 1.0 represents 360 degrees.",+		"\tfloat tilt             = float(whichTilt)         / float(numTilts);            // 0.0 represents the first tilt; 1.0 represents all tilts are done.",+		"\tfloat circleSampleRad_ = tau*circleSample;  // In radians.",+		"\tfloat tiltRad_         = tau*tilt;          // In radians.",+		"",+		"\tfloat circleSampleRad  = circleSampleRad_ + ballRot.z;  // rotatexy (aim right) - first transformation",+		"\tfloat spinRad          =                    ballRot.y;  // second transformation - only handles ball rotation about y axis.",+		"\tfloat tiltRad          = tiltRad_         + ballRot.x;  // rotateyz (aim down) - third transformation",+		"",+		"\t// Now calculate the raw vertex based on circleSample and tilt, all 3 axis rotations in fact, starting at radius 1 before we scale and apply pos and rot.",+		"\t// For the math, one way is to compose 3 rotatexx matrices.",+		"\t// rotateyz tiltRad <> rotatexz spinRad <> rotatexy circleSampleRad =",+		"\t//          (rotxy)",+		"\t//          c   s   0",+		"\t//          -s  c   0",+		"\t//          0   0   1",+		"\t// (rxz)",+		"\t// C  0  S  Cc  Cs  S",+		"\t// 0  1  0  -s  c   0",+		"\t// -S 0  C  -Sc -Ss C …",+		"",+		"\t//          (…)",+		"\t//          Cc  Cs  S",+		"\t//          -s  c   0",+		"\t//          -Sc -Ss C",+		"\t// (ryz)",+		"\t// 1  0  0  Cc  Cs  S",+		"\t// 0  č  š  (-čs-šSc) ( čc-šSs) (šC)",+		"\t// 0  -š č  ( šs-čSc) (-šc-čSs) (čC)",+		"\t//",+		"\t// Multiply the resulting matrix by the starting point 1,0,0 to get the raw position.",+		"\t// vec3 rawVertPos = Cc, -čs-šSc, šs-čSc",+		"\tfloat angleszc = cos(circleSampleRad);",+		"\tfloat angleszs = sin(circleSampleRad);",+		"\tfloat anglesyc = cos(spinRad);",+		"\tfloat anglesys = sin(spinRad);",+		"\tfloat anglesxc = cos(tiltRad);",+		"\tfloat anglesxs = sin(tiltRad);",+		"\tvec3 rawVertPos = vec3(anglesyc * angleszc, -anglesxc*angleszs-anglesxs*anglesys*angleszc, anglesxs*angleszs-anglesxc*anglesys*angleszc);",+		--"\tvec3 rawVertPosDebugMonolith = vec3(circleSampleRad, 0.0, tiltRad);  // Can be used for debugging purposes to see a monolith 2D ball.",+		"\tvec3 vertPos = ballPos + ballRadius*rawVertPos;",+		"\t// Apply the global transformation.",+		"\tvec4 glVertPos = transfMul(vec4(vertPos, 1.0));",+		"",+		"\tbool blackNotWhite = int(round(4*circleSample)) % 2 == int(round(4*tilt)) % 2;",+		"\tvec4 ballTriangleColor = blackNotWhite ? vec4(0.0, 0.0, 0.0, 0.8) : vec4(1.0, 1.0, 1.0, 0.8);",+		"",+		"\t// Write output.",+		"\tgl_Position = glVertPos;",+		"\tvertexModulateColor = ballTriangleColor;",+		"\tvertexTexCoords = vec2(0.0, 0.0);  // Fragment shader will ignore.",+		"\tvertexTexLayer = 0;  // Fragment shader will ignore.",+		"\tdoDiscard = 0;",+		"}",+		"",+		"void mainUnknown() {",+		"\tgl_Position = vec4(0.0, 0.0, 0.0, 1.0);",+		"\tvertexModulateColor = vec4(0.0, 0.0, 0.0, 0.0);",+		"\tvertexTexCoords = vec2(0.0, 0.0);",+		"\tvertexTexLayer = 0;",+		"\tdoDiscard = 1;",+		"}",+		"",+		"void main() {",+		"\tif (!(enableSceneData != 0) && !(enableBallData != 0)) {",+		"\t\tmainGUI();",+		"\t} else if ((enableSceneData != 0) && !(enableBallData != 0)) {",+		"\t\tmainScene();",+		"\t} else if (!(enableSceneData != 0) && (enableBallData != 0)) {",+		"\t\tmainBall();",+		"\t} else {",+		"\t\t// Unknown configuration / shader mode; unknown what to draw.",+		"\t\tmainUnknown();",+		"\t}",+		"}",+		"",+		""+	]++fragmentShader :: String+fragmentShader = unlines $+	[+		"#version 450 core",+		"",+		"in  vec4  gl_FragCoord;",+		"out vec4  fragmentColor;",+		"out float gl_FragDepth;",+		"",+		"in      vec4 vertexModulateColor;",+		"in      vec2 vertexTexCoords;",+		"in flat int  vertexTexLayer;",+		"in flat int  doDiscard;",+		"",+		"layout(location = 16) uniform int       enableSceneData;",+		"layout(location = 34) uniform int       enableBallData;",+		"layout(location = 35) uniform float     ballRadius;",+		"layout(location = 36) uniform int       ballNumTriangles;",+		"layout(location = 37) uniform vec3      ballPos;",+		"layout(location = 38) uniform vec3      ballRot;",+		"",+		"layout(location =  0) uniform sampler2D texture0;",+		"layout(location =  1) uniform sampler2D texture1;",+		"layout(location =  2) uniform sampler2D texture2;",+		"layout(location =  3) uniform sampler2D texture3;",+		"layout(location =  4) uniform sampler2D texture4;",+		"layout(location =  5) uniform sampler2D texture5;",+		"layout(location =  6) uniform sampler2D texture6;",+		"layout(location =  7) uniform sampler2D texture7;",+		"layout(location =  8) uniform sampler2D texture8;",+		"layout(location =  9) uniform sampler2D texture9;",+		"layout(location = 10) uniform sampler2D texture10;",+		"layout(location = 11) uniform sampler2D texture11;",+		"layout(location = 12) uniform sampler2D texture12;",+		"layout(location = 13) uniform sampler2D texture13;",+		"layout(location = 14) uniform sampler2D texture14;",+		"layout(location = 15) uniform sampler2D texture15;",+		"",+		"\t// Draw the GUI or the level.",+		"void mainGUIOrScene() {",+		"\tgl_FragDepth = 1.0e-6 * gl_FragCoord.z/gl_FragCoord.w;",+		"\tfragmentColor = ",+		"\t\tvertexTexLayer ==  0 ? texture(texture0,  vertexTexCoords) * vertexModulateColor :",+		"\t\tvertexTexLayer ==  1 ? texture(texture1,  vertexTexCoords) * vertexModulateColor :",+		"\t\tvertexTexLayer ==  2 ? texture(texture2,  vertexTexCoords) * vertexModulateColor :",+		"\t\tvertexTexLayer ==  3 ? texture(texture3,  vertexTexCoords) * vertexModulateColor :",+		"\t\tvertexTexLayer ==  4 ? texture(texture4,  vertexTexCoords) * vertexModulateColor :",+		"\t\tvertexTexLayer ==  5 ? texture(texture5,  vertexTexCoords) * vertexModulateColor :",+		"\t\tvertexTexLayer ==  6 ? texture(texture6,  vertexTexCoords) * vertexModulateColor :",+		"\t\tvertexTexLayer ==  7 ? texture(texture7,  vertexTexCoords) * vertexModulateColor :",+		"\t\tvertexTexLayer ==  8 ? texture(texture8,  vertexTexCoords) * vertexModulateColor :",+		"\t\tvertexTexLayer ==  9 ? texture(texture9,  vertexTexCoords) * vertexModulateColor :",+		"\t\tvertexTexLayer == 10 ? texture(texture10, vertexTexCoords) * vertexModulateColor :",+		"\t\tvertexTexLayer == 11 ? texture(texture11, vertexTexCoords) * vertexModulateColor :",+		"\t\tvertexTexLayer == 12 ? texture(texture12, vertexTexCoords) * vertexModulateColor :",+		"\t\tvertexTexLayer == 13 ? texture(texture13, vertexTexCoords) * vertexModulateColor :",+		"\t\tvertexTexLayer == 14 ? texture(texture14, vertexTexCoords) * vertexModulateColor :",+		"\t\tvertexTexLayer == 15 ? texture(texture15, vertexTexCoords) * vertexModulateColor :",+		"\t\tvec4(0.0, 0.0, 0.0, 0.0);",+		"}",+		"",+		"\t// Draw the ball.",+		"void mainBall() {",+		"\tgl_FragDepth = 1.0e-6 * gl_FragCoord.z/gl_FragCoord.w;",+		"\tfragmentColor = vertexModulateColor;",+		"}",+		"",+		"void main() {",+		--"\tfragmentColor = texture(texture0, vertexTexCoords);",+		"\tif ((doDiscard != 0)) {",+		"\t\tdiscard;",+		"\t} else if (!(enableSceneData != 0) && (enableBallData != 0)) {",+		"\t\tmainBall();",+		"\t} else {",+		"\t\tmainGUIOrScene();",+		"\t}",+		"}",+		"",+		""+	]
+ Immutaball/Share/Wire.hs view
@@ -0,0 +1,349 @@+{-# 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 #-}++-- State.hs.++{-# LANGUAGE Haskell2010 #-}+{-# LANGUAGE TemplateHaskell, Arrows, DerivingVia, RankNTypes #-}++-- | Besides low-level wire construction,+-- ArrowLoop's ‘loop’ helps provide for local state, e.g. as in the ‘counter’+-- example in+-- https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/arrows.html+-- ; with loop we can use ‘Arrows’ syntax with ‘rec’ with a delayed update.+module Immutaball.Share.Wire+	(+		-- * Primitives+		--Wire,+		Wire(..), reinstancedWire,+		stepWire,+		wire,+		delayWire,+		loopWire,+		loopWireSimple,+		monadic,++		-- * Utilities+		initial,+		withM,+		delay,+		delayWith,+		integrate,+		differentiate,+		hold,+		holdWith,+		replaceNow,+		replace,+		switchNow,+		switch,+		apply,+		queue,+		queueN,+		queueNI,+		delayN,+		delayNI,+		returnWire,+		constWire,+		multistep,+		foldrA,+		foldrListA,+		multistepFeedback,+		multistepFeedbackList,+		foldlA,+		foldlListA,+		constA,+		nopA,+		wave+	) where++import Prelude ()+import Immutaball.Prelude++import Control.Arrow+import Control.Monad.Fix+import Data.Foldable+--import Data.Function+import Data.Functor.Identity+import Data.List++import Control.Lens+--import Control.Wire (Wire)+import qualified Control.Wire+import qualified Control.Wire.Controller+import qualified Control.Wire.Internal (Wire(Wire))++import Control.Monad.Trans.MaybeM (NaturalTransformation)+import Immutaball.Share.Math+import Immutaball.Share.Utils++-- * Primitives++-- newtype Wire m a b = { _wireStep :: a -> m (b, Wire m a b) }+-- | A wire.  A function that changes itself each time it is called / stepped.+--+-- Note that -<< would discard wires with this, which might not be what you want.+-- Beware that the left side of '-<<' may ‘never advance’ in stepping!  (-<<+-- does have uses, e.g. see 'replaceNow' where ‘-<<’ is exactly what we want+-- there and correct.)+newtype Wire m a b = ReinstanceWire { _reinstancedWire :: Control.Wire.Wire m a b }+	deriving (Functor, Applicative)+		via (Control.Wire.Wire m a)+	deriving (Arrow, ArrowChoice, ArrowLoop, {-Choice, Strong, Costrong, Profunctor, -}Category)+		via (Control.Wire.Wire m)+makeLenses ''Wire+-- (Without newtype wrapper we get a warning: orphan instance.)+-- Note that -<< would discard wires with this, which might not be what you want.+-- Beware that the left side of '-<<' may ‘never advance’ in stepping!+instance (Monad m) => ArrowApply (Wire m) where+	app = apply++-- | Run a 'Wire'.+stepWire :: (Functor m) => Wire m a b -> a -> m (b, Wire m a b)+--stepWire = Control.Wire.Controller.stepWire+stepWire w a = second ReinstanceWire <$> Control.Wire.Controller.stepWire (_reinstancedWire w) a++-- | Expose primitives that IMO should be already non-internal, or at the very+-- least accessible through a non-internal interface.  Weirdly, I found no way+-- to represent a function equivalent to ‘Wire’ using only the non-internal+-- ‘wires’ API.+wire :: (Functor m) => (a -> m (b, Wire m a b)) -> Wire m a b+--wire = Control.Wire.Internal.Wire+wire wireStep_ = ReinstanceWire . Control.Wire.Internal.Wire $ \a -> second _reinstancedWire <$> wireStep_ a++-- | 'Wire' provides us with a delay, in contrast with '->'.+delayWire :: (Functor m) => b -> Wire m a b -> Wire m a b+--delayWire y0 wire_ = wire $ \x -> (\(y, wire') -> (y0, delayWire y wire')) <$> stepWire wire_ x+delayWire y0 wire_ = wire $ \x -> (\ ~(y, wire') -> (y0, delayWire y wire')) <$> stepWire wire_ x++-- | 'Wire' is an instance of 'ArrowLoop'.+loopWire :: (Monad m, MonadFix m) => Wire m (b, d) (c, d) -> Wire m b c+loopWire w = wire $ \b -> (\ ~( ~(c, _d), w') -> (c, loopWire w')) <$> (mfix $ \ ~( ~(_c, d), _w') -> stepWire w (b, d))++-- | Simple example with Identity.+loopWireSimple :: Wire Identity (b, d) (c, d) -> Wire Identity b c+--loopWireSimple w = wire $ \b -> let Identity ((c, d), w') = stepWire w (b, d) in Identity (c, loopWireSimple w')+loopWireSimple = fix $ \loopWireSimple_ w -> wire $ \b -> let Identity ((c, _d), w') = fix (\(Identity ((_c, d), _w')) -> stepWire w (b, d)) in Identity (c, loopWireSimple_ w')++-- | Run the given action in the monad.+monadic :: (Applicative m) => Wire m (m a) a+monadic = wire $ \m -> (\a -> (a, monadic)) <$> m++-- * Utilities++-- | For a vesion that always applies the input, see 'monadic'.+--+-- This version only initializes the monadic action once.+initial :: (Applicative m) => Wire m (m a) a+initial = wire $ \m -> (\a -> (a, pure a)) <$> m++-- | The monad is only used to initialize the wire; it is not repeated.+withM :: (Monad m) => (s -> Wire m a b) -> (a -> m s) -> Wire m a b+withM initWire initState = wire $ \a -> initState a >>= \s -> stepWire (initWire s) a++delay :: (Monad m) => a -> Wire m a a+delay y0 = delayWire y0 returnA++-- TODO: test delayWith.++-- | A 'delay' variant that takes the initial value through the wire.+--+-- The _second_ argument (not the first) is the initial value.+--+-- The initial argument is ignored after the first frame.+delayWith :: (Monad m) => Wire m (a, a) a+delayWith = wire $ \(y1, y0) -> pure (y0, delay y1 <<< arr fst)++integrate :: (Num a, Monad m, MonadFix m) => a -> Wire m a a+-- Low-level example for knowledge aid:+--integrate y0 = flip fix y0 $ \me y -> wire $ \x -> let result = y + x in return (result, me result)+integrate y0 = proc x -> do+	rec output <- delay y0 -< output + x+	returnA -< output++differentiate :: (Num a, Monad m, MonadFix m) => Wire m a a+differentiate = proc x -> do+	lastX <- delayWith -< (x, x)+	returnA -< x - lastX++-- | Output the last available input.+hold :: (Monad m, MonadFix m) => a -> Wire m (Maybe a) a+-- A shorter style:+{-+hold a0 = proc ma -> do+	rec lastJust <- delay a0 -< maybe lastJust id ma+	returnA -< maybe lastJust id ma+-}+-- Arrows counter-style:+-- {-+hold a0 = proc ma -> do+	rec+		output <- returnA -< maybe lastJust id ma+		lastJust <- delay a0 -< output+	returnA -< output+-- -}++-- TODO: test holdWith++-- | A 'hold' variant that takes the initial value through the wire.+--+-- The initial argument is ignored after being reset.+holdWith :: (Monad m, MonadFix m) => Wire m (Maybe a, a) a+holdWith = proc (set_, initial_) -> do+	rec+		output <- returnA -< maybe lastOutput id set_+		lastOutput <- delayWith -< (output, initial_)+	returnA -< output++-- TODO: test replace*, switch*, and apply.++-- | Feed the input back into the new wire.+replaceNow :: (Monad m) => Wire m a (Wire m a b) -> Wire m a b+-- This is the direct version, which we are keeping for reference:+-- Actually, we commented out the ArrowApply instance (keeping arrowDiscard),+-- although arrowDiscard is exactly what we want here and correct, so use the+-- direct version now rather than the proc syntax.+{-+replaceNow w0 = wire $ \a -> stepWire w0 a >>= \(b, _w1) -> stepWire b a+-}+-- Here is a higher level version, which we are using:+-- Without instance ArrowApply:+-- ‘Could not deduce ‘ArrowApply (Wire m)’’:+-- {-+replaceNow w0 = proc a -> do+	b <- w0 -< a+	b -<< a+-- -}++-- | Discards the outer new wire, replacing it with the output wire instead.+replace :: (Functor m) => Wire m a (b, (Wire m a b)) -> Wire m a b+--replace w0 = wire $ \a -> (\(b, w1) -> delayWire b w1) <$> stepWire w0 a+replace w0 = wire $ \a -> (\((b, w1), _w1Outer) -> (b, w1)) <$> stepWire w0 a++-- | Feed the input back into the new wire.+switchNow :: (Monad m) => Wire m a (Either (Wire m a b) b) -> Wire m a b+switchNow w0 = wire $ \a -> stepWire w0 a >>= \(eb, w1) -> either (\w1Override -> stepWire w1Override a) (\b -> return (b, switchNow w1)) eb++-- | Optionally discard the outer new wire, replacing it with the provided+-- output wire instead.+switch :: (Functor m) => Wire m a (b, Maybe (Wire m a b)) -> Wire m a b+switch w0 = wire $ \a -> (\((b, mw1), w1Outer) -> (b, maybe (switch w1Outer) id mw1)) <$> stepWire w0 a++-- | Discards the wire; gives the result.+--+-- Each wire produces a wire sequence for future wires in time, but at every+-- frame the entire sequence is discarded and replaced with the new wire that+-- is provided as input.+--+-- Note that -<< would discard wires with this, which might not be what you want.+-- Beware that the left side of '-<<' may ‘never advance’ in stepping!+apply :: (Functor m) => Wire m (Wire m a b, a) b+-- Here is a version that uses monads:+--apply = wire $ \(w0, a) -> stepWire w0 a >>= \(b, _w1) -> return (b, apply)+-- We only need fmap here:+apply = wire $ \(w0, a) -> (\(b, _w1) -> (b, apply)) <$> stepWire w0 a++-- | Process one input each frame.+queue :: (Applicative m, MonadFix m) => Wire m [a] (Maybe a)+--queue = flip fix [] $ \me queued -> wire $ \(as) -> let as' = queued ++ as in pure (safeHead as', me (drop 1 as'))+queue = proc ins -> do+	rec+		(output, queue) <- returnA -< let ins' = lastQueue ++ ins in (safeHead ins', drop 1 ins')+		lastQueue <- delay [] -< queue+	returnA -< output++-- TODO: test queueN.++-- | Send at most N chunks at once.+queueN :: (Integral i, Monad m, MonadFix m) => i -> Wire m [a] [a]+queueN n = queueNI (fromIntegral n)++-- | 'queueN' variant specialized to Integer.+queueNI :: (Monad m, MonadFix m) => Integer -> Wire m [a] [a]+queueNI n = proc ins -> do+	rec+		(chunk, queue) <- returnA -< let ins' = lastQueue ++ ins in (genericTake n ins', genericDrop n ins')+		lastQueue <- delay [] -< queue+	returnA -< chunk++-- | Delay a given number of frames >= 0, with the same output for all frames+-- in between.+delayN :: (Integral i, Applicative m) => i -> a -> Wire m a a+delayN n y0tn = delayNI (fromIntegral n) y0tn++-- | 'delayN' variant specialized to Integer.+delayNI :: (Applicative m) => Integer -> a -> Wire m a a+delayNI n y0tn+	| n < 0     = error $ "delayNI: negative argument: " ++ (show n)+	| 0 <- n    = returnWire+	| otherwise = delayWire y0tn (delayNI (n-1) y0tn)++-- | The identity wire.+returnWire :: (Applicative m) => Wire m a a+returnWire = wire $ \a -> pure (a, returnWire)++-- | An input ignoring wire.+constWire :: (Applicative m) => b -> Wire m a b+constWire b = wire $ \_ -> pure (b, constWire b)++-- TODO: add test multiStep.++-- | Step the wire multiple times, once for each input.+--+-- If we had dependent types in our language, we could probably represent+-- equality of lengths.+multistep :: (Monad m) => Wire m a b -> Wire m [a] [b]+multistep w0 = wire . flip fix w0 $ \me wn as -> case as of+	[]        -> pure ([], multistep wn)+	(an:rest) -> stepWire wn an >>= \(bn, wnp1) -> first (bn:) <$> me wnp1 rest++-- TODO: see if can maybe you can do something like class LeftArrow with inArr :: ((a -> b) -> c) -> Arr … ?+----inArrWire :: ((a -> b) -> c) -> Wire m a b -> Wire m () c+--inArrWire :: ((a -> b) -> (c -> d)) -> Wire m a b -> Wire m c d+--inArrWire f w = wire $ \c -> f $ \a -> ???++foldrA :: (Foldable t, Monad m, MonadFix m) => Wire m (a, b) b -> Wire m (b, t a) b+foldrA reduce = foldrListA reduce <<< second (arr toList)++foldrListA :: (Monad m, MonadFix m) => Wire m (a, b) b -> Wire m (b, [a]) b+foldrListA reduce = proc (reduction0, xs) -> do+	--foldr reduce reduction0 [] = reduction0+	--foldr reduce reduction0 (x:rest) = reduce x (foldr reduce reduction0 rest)+	case xs of+		[] -> returnA -< reduction0+		(x:rest) -> reduce <<< second (foldrListA reduce) -< (x, (reduction0, rest))++-- | 'multistep', with a value for the previous (or initial) result.+--+-- Step the wire multiple times in a single frame.  Add a state value between+-- steps.+multistepFeedback :: (Monad m, MonadFix m) => NaturalTransformation t [] -> NaturalTransformation [] t -> Wire m (a, b) (c, b) -> Wire m (t a, b) (t c, b)+multistepFeedback toList_ fromList_ step = first (arr fromList_) <<< multistepFeedbackList step <<< first (arr toList_)++-- | 'multistepFeedback' specialized to lists.+multistepFeedbackList :: (Monad m, MonadFix m) => Wire m (a, b) (c, b) -> Wire m ([a], b) ([c], b)+multistepFeedbackList w0 = wire . flip fix w0 $ \me wn (as, b) -> case as of+	[]      -> pure (([], b), multistepFeedbackList wn)+	(a:as') -> stepWire wn (a, b) >>= \((c, b'), wnp1) -> first (first (c:)) <$> me wnp1 (as', b')++foldlA :: (Foldable t, Monad m, MonadFix m) => Wire m (b, a) b -> Wire m (b, t a) b+foldlA reduce = foldlListA reduce <<< second (arr toList)++foldlListA :: (Monad m, MonadFix m) => Wire m (b, a) b -> Wire m (b, [a]) b+foldlListA reduce = proc (reduction0, xs) -> do+	--foldl reduce reduction0 [] = reduction0+	--foldl reduce reduction0 (x:rest) = foldl reduce (reduce reduction0 x) rest+	case xs of+		[] -> returnA -< reduction0+		(x:rest) -> foldlListA reduce <<< first reduce -< ((reduction0, x), rest)++constA :: (Arrow a) => c -> a b c+constA c = arr (const c)++nopA :: (Arrow a) => a () ()+nopA = arr $ \() -> ()++wave :: (Floating a, Monad m, MonadFix m) => a -> a -> a -> Wire m a a+wave amplitude period phase = proc dt -> do+	t <- integrate 0 -< dt+	returnA -< amplitude * (sin $ tau*(t + phase)/period)
+ LICENSE.md view
@@ -0,0 +1,36 @@+# Licensing and exceptions++Immutaball is licensed under the terms of the GNU General Public License+version 3 or later (at your option), since it is a derivative work of Neverball+1.7.0-alpha.3, which is released under the terms of the GNU General Public+License version 2 or a later version (at your option), and links with its data+files.  The full texts of GPLv3 and GPLv2 are included in `doc/legal/`.++Immutaball core, under `src/`, is a port of Neverball core to Haskell.  The+separable components of Immutaball core independent from Neverball core are+licensed under the terms of 0BSD, the text of which is included in+`doc/legal/`.  Consent here is thus also provided under the terms of 0BSD as+well.  (The combined project, as stated, is licensed under GPL-3.0-or-later to+be compliant with the usage terms of the dependencies it uses.)++Immutaball uses a number of external libraries.  Certain features that can be+enabled at compile time require additional libraries.  Binary versions of these+libraries are sometimes distributed with Immutaball. Licensing information for+these libraries is included in `doc/legal/`.++Immutaball includes a number of third party fonts. The DejaVu font+(`submodules/neverball/data/ttf/DejaVuSans-Bold.ttf`) license is included in+`doc/legal/`. The WenQuanYi Micro Hei font+(`submodules/neverball/data/ttf/wqy-microhei.ttc`) is dual licensed under+Apache 2.0 or GPLv3. The full text of GPLv3 is included in `doc/legal/`.++Neverball uses the Octocat ball `submodules/neverball/data/ball/octocat` with+the Octocat design with permission permission from Github dated 2013-11-12.+Wording of approval is in `doc/legal`.++The source file `submodules/neverball/share/fs_jpg.c` is based on `jdatasrc.c`+from the libjpeg project.++The source files `submodules/neverball/share/miniz.[ch]` are included verbatim+from the miniz project (https://github.com/richgel999/miniz) and are licensed+under the MIT license. See `doc/legal/license-miniz.txt`.
+ Main.hs view
@@ -0,0 +1,18 @@+#!/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'+-}+{-# 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 #-}++-- Main.hs: Immutaball.++{-# LANGUAGE Haskell2010 #-}++module Main where++import qualified Immutaball.Ball.Main++main :: IO ()+main = Immutaball.Ball.Main.main
+ Putt.hs view
@@ -0,0 +1,18 @@+#!/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'+-}+{-# 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 #-}++-- Main.hs: Immutaball.++{-# LANGUAGE Haskell2010 #-}++module Main where++import qualified Immutaball.Putt.Main++main :: IO ()+main = Immutaball.Putt.Main.main
+ README.md view
@@ -0,0 +1,115 @@+# 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.++# Immutaball++Immutaball is a rewrite of Neverball in Haskell.  It is useful for gaming and+studying a purely functional FRP application.  It does not use IO except for+interfacing with external dependencies and ‘base’/‘haskell2010’ IO primitives+like writing to a file (including concurrent evaluation).++# Screenshots and demo++![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+```++## 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+```
+ Test.hs view
@@ -0,0 +1,18 @@+#!/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'+-}+{-# 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 #-}++module Main where++import qualified Test.Immutaball.Test++main :: IO ()+main = Test.Immutaball.Test.main
+ Test/Immutaball/Share/Math/Core/Orphans.hs view
@@ -0,0 +1,41 @@+{-# 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 TemplateHaskell #-}++{-# OPTIONS_GHC -Wno-orphans #-}++module Test.Immutaball.Share.Math.Core.Orphans+	(+	) where++import Prelude ()+import Immutaball.Prelude++import Test.QuickCheck++import Immutaball.Share.Math++instance (Arbitrary a) => Arbitrary (Vec2 a) where+	arbitrary = Vec2 <$> arbitrary <*> arbitrary+	shrink (Vec2 x y) = [Vec2 x' y' | (x', y') <- shrink (x, y)]++instance (Arbitrary a) => Arbitrary (Vec3 a) where+	arbitrary = Vec3 <$> arbitrary <*> arbitrary <*> arbitrary+	shrink (Vec3 x y z) = [Vec3 x' y' z' | (x', y', z') <- shrink (x, y, z)]++instance (Arbitrary a) => Arbitrary (Vec4 a) where+	arbitrary = Vec4 <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary+	shrink (Vec4 x y z w) = [Vec4 x' y' z' w' | (x', y', z', w') <- shrink (x, y, z, w)]++instance (Arbitrary a) => Arbitrary (Mat3 a) where+	arbitrary = Mat3 <$> arbitrary+	shrink (Mat3 rows) = Mat3 <$> shrink rows++instance (Arbitrary a) => Arbitrary (Mat4 a) where+	arbitrary = Mat4 <$> arbitrary+	shrink (Mat4 rows) = Mat4 <$> shrink rows
+ Test/Immutaball/Share/Math/Core/Test.hs view
@@ -0,0 +1,283 @@+{-# 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 Arrows, ScopedTypeVariables #-}++module Test.Immutaball.Share.Math.Core.Test+	(+		main,+		testsMain,+		tests,++		simpleConstant,+		right3,+		forward3,+		up3,+		right2,+		up2,+		eq3Duplicate,+		zint,+		zdouble,+		circle,+		eqEachEach,+		v3normalized+	) where++--import Control.Arrow+--import Data.Functor.Identity++import Control.Lens+import Test.HUnit+--import Test.QuickCheck+import Test.Tasty+import Test.Tasty.HUnit hiding ((@?=), assertBool)+import Test.Tasty.QuickCheck++import Immutaball.Share.Math+import Immutaball.Share.Utils+import Test.Immutaball.Share.Math.Core.Orphans ()++main :: IO ()+main = testsMain++testsMain :: IO ()+testsMain = defaultMain tests++simpleConstant :: Integer+simpleConstant = 3++right3 :: Vec3 Double+right3 = Vec3 1.0 0.0 0.0++forward3 :: Vec3 Double+forward3 = Vec3 0.0 1.0 0.0++up3 :: Vec3 Double+up3 = Vec3 0.0 0.0 1.0++right2 :: Vec2 Double+right2 = Vec2 1.0 0.0++up2 :: Vec2 Double+up2 = Vec2 0.0 1.0++eq3Duplicate :: Vec3 Double -> Vec3 Double -> Bool+eq3Duplicate a b = abs ((b - a)^.r3) <= smalld++-- | Helps resolve default type to Integer warnings when using ‘0’.+zint :: Integer+zint = 0++zdouble :: Double+zdouble = 0.0++-- | Similar but to specialize to 'float' so that equivalence checks'+-- thresholds aren't too tight.+circle :: Float+circle = tau++-- | Given a list of values possibly known to already be unique, return a bool+-- that is True if the equality comparison on each possible pairing of values+-- is as expected.+--+-- If e.g. the values are randomly generated, they might not be unique, so only+-- check each value with each other in this case.+eqEachEach :: Bool -> (a -> a -> Bool) -> [a] -> Bool+eqEachEach guaranteedUnique eq vals =+	and $+		[ r+		| ivals <- return $ zip [zint..] vals+		, (ai, av) <- ivals+		, (bi, bv) <- ivals+		, guaranteedUnique || ai == bi+		, r <- return $ (ai == bi) == (av `eq` bv)+		]++-- | v3normalize specialized to 'Double'.+v3normalized :: Vec3 Double -> Vec3 Double+v3normalized = v3normalize++tests :: TestTree+tests = testGroup "Immutaball.Share.Math.Core" $+	[+		testCase "simpleConstant == 3" $+			simpleConstant @?= 3,++		testGroup "meta tests" $+			[+				testCase "right3 == right3" $+					right3 `eq3Duplicate` right3 @?= True,+				testCase "right3 /= forward3" $+					right3 `eq3Duplicate` forward3 @?= False,+				testCase "each axis unit vector equality checks correctly with each" $+					and [r | axes <- return $ zip [zint..] [right3, forward3, up3], (ai, av) <- axes, (bi, bv) <- axes, r <- return $ (ai == bi) == (av `eq3Duplicate` bv)] @?= True,+				testCase "each axis unit vector equality checks correctly with each" $+					eqEachEach True eq3Duplicate [right3, forward3, up3] @?= True+			],++		testGroup "eq3 tests" $+			[+				testCase "right3 == right3" $+					right3 `eq3` right3 @?= True,+				testCase "right3 /= forward3" $+					right3 `eq3` forward3 @?= False,+				testCase "each axis unit vector equality checks correctly with each" $+					and [r | axes <- return $ zip [zint..] [right3, forward3, up3], (ai, av) <- axes, (bi, bv) <- axes, r <- return $ (ai == bi) == (av `eq3` bv)] @?= True,+				testCase "each axis unit vector equality checks correctly with each" $+					eqEachEach True eq3 [right3, forward3, up3] @?= True+			],++		testGroup "eqEachEach for vecs and mats" $+			[+				testGroup "randomly generated" $+					[+						testProperty "eqEachEach random vec2" $+							\(vals :: [Vec2 Double]) -> eqEachEach False eq2 vals,+						testProperty "eqEachEach random vec3" $+							\(vals :: [Vec3 Double]) -> eqEachEach False eq3 vals,+						testProperty "eqEachEach random vec4" $+							\(vals :: [Vec4 Double]) -> eqEachEach False eq4 vals,+						testProperty "eqEachEach random mat3" $+							\(vals :: [Mat3 Double]) -> eqEachEach False eqm3 vals,+						testProperty "eqEachEach random mat4" $+							\(vals :: [Mat4 Double]) -> eqEachEach False eqm4 vals+					],++				testGroup "fixed" $+					[+						testCase "eqEachEach fixed vec2" $+							eqEachEach True eq2 [pure zdouble, pure 2.0, pure 3.5, pure $ -1.0] @?= True,+						testCase "eqEachEach fixed vec3" $+							eqEachEach True eq3 [pure zdouble, pure 2.0, pure 3.5, pure $ -1.0] @?= True,+						testCase "eqEachEach fixed vec4" $+							eqEachEach True eq4 [pure zdouble, pure 2.0, pure 3.5, pure $ -1.0] @?= True,+						testCase "eqEachEach fixed mat3" $+							eqEachEach True eqm3 [pure zdouble, pure 2.0, pure 3.5, pure $ -1.0] @?= True,+						testCase "eqEachEach fixed mat4" $+							eqEachEach True eqm4 [pure zdouble, pure 2.0, pure 3.5, pure $ -1.0] @?= True+					],++				testGroup "randomly generated, near" $+					[+						testProperty "eqEachEach random vec2 near" $+							\(vals :: [Vec2 Double]) -> eqEachEach False near2 vals,+						testProperty "eqEachEach random vec3 near" $+							\(vals :: [Vec3 Double]) -> eqEachEach False near3 vals,+						testProperty "eqEachEach random vec4 near" $+							\(vals :: [Vec4 Double]) -> eqEachEach False near4 vals,+						testProperty "eqEachEach random mat3 near" $+							\(vals :: [Mat3 Double]) -> eqEachEach False nearm3 vals,+						testProperty "eqEachEach random mat4 near" $+							\(vals :: [Mat4 Double]) -> eqEachEach False nearm4 vals+					]+			],++		testGroup "some normalization tests" $+			[+				testCase "normalizing 1,1,1 gets 1/sqrt 3 x3." $+					v3normalized (Vec3 1.0 1.0 1.0) `near3` v3normalize (Vec3 (1/sqrt 3) (1/sqrt 3) (1/sqrt 3)) @?= True,+				testCase "normalizing 1,2,3 gets /sqrt 14." $+					v3normalized (Vec3 1.0 2.0 3.0) `near3` v3normalize (Vec3 (1.0/sqrt 14) (2.0/sqrt 14) (3.0/sqrt 14)) @?= True+			],++		testGroup "3D pointing orientation utils (aiming) - using floats so that equality checks' precisions aren't too tight" $+			[+				testCase "aim right 1/8th circle" $+					--D.trace (printf "DEBUG0: left is %s and right is %s." (show $ aimHoriz3DSimple (circle/8) (Vec3 0.0 1.0 0.0)) (show $ (Vec3 (sqrt 0.5) (sqrt 0.5) 0.0))) $+					aimHoriz3DSimple (circle/8) (Vec3 0.0 1.0 0.0) `eq3` (Vec3 (sqrt 0.5) (sqrt 0.5) 0.0) @?= True,+				testCase "aim right 30 degrees" $+					aimHoriz3DSimple (circle/12) (Vec3 0.0 1.0 0.0) `eq3` (Vec3 (1.0 / 2.0) (sqrt 3.0 / 2.0) 0.0) @?= True,++				testCase "look 45 deg up from 30 deg right" $+					-- length of Vec2 x y should be equal to z here, so that it's a right angle.+					-- prenormalized:+					-- 	  (Vec3 (1.0 / 2.0) (sqrt 3.0 / 2.0) (sqrt $ x^2 + y^2))+					-- 	= (Vec3 (1.0 / 2.0) (sqrt 3.0 / 2.0) (sqrt $ 1/4 + 3/4))+					-- 	= (Vec3 (1.0 / 2.0) (sqrt 3.0 / 2.0) 1.0)+					-- prenormalized^.r: sqrt (1/4 + 3/4 + 1^2) = sqrt (1 + 1) = sqrt 2+					-- normalized:+					-- 	  (Vec3 (1.0      / 2.0) (sqrt 3.0 / 2.0) 1.0             ) / sqrt 2+					-- 	= (Vec3 (sqrt 2.0 / 4.0) (sqrt 1.5 / 2.0) (sqrt 2.0 / 2.0))+					--D.trace (printf "DEBUG0: left is %s and right is %s." (show $ aimVert3DSimple Nothing (circle/8) (Vec3 (1.0 / 2.0) (sqrt 3.0 / 2.0) 0.0)) (show $ Vec3 (sqrt 2.0 / 4.0) (sqrt 1.5 / 2.0) (sqrt 2.0 / 2.0  :: Float))) $+					aimVert3DSimple Nothing (circle/8) (Vec3 (1.0 / 2.0) (sqrt 3.0 / 2.0) 0.0) `near3` (Vec3 (sqrt 2.0 / 4.0) (sqrt 1.5 / 2.0) (sqrt 2.0 / 2.0)) @?= True,++				testProperty "aimVert on point in yz == rotateyzSimple *±1" $+					\(randomPointOnYz :: Vec2 Double) (randomPitchRadiansDown :: Double) ->+					let randomPoint = Vec3 0.0 (randomPointOnYz^.x2) (randomPointOnYz^.y2) in++					let planeRotateNeedsNegate = randomPoint^.y3 < 0 in++					-- Actual+					let byAimVert = aimVert3DSimple Nothing (-randomPitchRadiansDown) $ randomPoint in+					-- Expected+					let byPlaneRotate = rotateyzSimple (randomPitchRadiansDown * if' planeRotateNeedsNegate (-1.0) 1.0) `mv3` randomPoint in++					-- Optional debugging:+					--D.trace (printf "DEBUG1:\n\trandomPointOnYz: %s\n\trandomPitchRadiansDown: %s\n\trandomPoint: %s\n\tplaneRotateNeedsNegate: %s\n\tbyAimVert     (actual)   : %s\n\tbyPlaneRotate (expected) : %s" (show $ randomPointOnYz) (show $ randomPitchRadiansDown) (show $ randomPoint) (show $ planeRotateNeedsNegate) (show $ byAimVert) (show $ byPlaneRotate)) $++					byAimVert `near3` byPlaneRotate,++				testGroup "tilt3y" $+					[+						testCase "tilt3y on 0,1,0 gives same result (look 45 deg up from 30 deg right)" $+							tilt3ySimple (Vec3 (sqrt 2.0 / 4.0) (sqrt 1.5 / 2.0) (sqrt 2.0 / 2.0)) `mv3` forward3 @?= (Vec3 (sqrt 2.0 / 4.0) (sqrt 1.5 / 2.0) (sqrt 2.0 / 2.0)),+						testCase "tilt3y 0,1,0 on (look 45 deg up from 30 deg right) gives (look 45 deg up from 30 deg right) (no change)" $+							tilt3ySimple forward3 `mv3` (Vec3 (sqrt 2.0 / 4.0) (sqrt 1.5 / 2.0) (sqrt 2.0 / 2.0)) @?= (Vec3 (sqrt 2.0 / 4.0) (sqrt 1.5 / 2.0) (sqrt 2.0 / 2.0)),+						testCase "tilt3y 1,0,0 on (look 45 deg up from 30 deg right) gives (look 45 deg up from 120 deg right) (just xy %~ *i**3 of last test's expected)" $+							(tilt3ySimple right3 `mv3` (Vec3 (sqrt 2.0 / 4.0) (sqrt 1.5 / 2.0) (sqrt 2.0 / 2.0))) `near3` (Vec3 (sqrt 1.5 / 2.0) (-sqrt 2.0 / 4.0) (sqrt 2.0 / 2.0)) @?= True,+						testProperty "tilt3y == aimHoriz <> aimVert by near" $+							let v3normalize' v = v3normalize v `v3orWith` right3 in+							-- Apply a random camera target tilt to a random position.  (Camera's at origin.)+							\(relCamTarget_ :: Vec3 Double) (randomPos :: Vec3 Double) ->+							let relCamTarget = v3normalize' relCamTarget_ in+							let byTilt3y = tilt3ySimple relCamTarget `mv3` randomPos in+							let relCamTargetxy = Vec2 (relCamTarget^.x3) (relCamTarget^.y3) in+							let byAims = aimVert3DSimple Nothing ((Vec2 (relCamTargetxy^.r2) (relCamTarget^.z3))^.t2) . aimHoriz3DSimple (up2^.t2 - relCamTargetxy^.t2) $ randomPos in+							byTilt3y `near3` byAims,+						testCase "tilt3y 0,0,1 on (look 45 deg up from 30 deg right) gives (look 45 deg up from 30 deg right then yz %~ *i)" $+							(tilt3ySimple up3 `mv3` (Vec3 (sqrt 2.0 / 4.0) (sqrt 1.5 / 2.0) (sqrt 2.0 / 2.0))) `near3` (Vec3 (sqrt 2.0 / 4.0) (-sqrt 2.0 / 2.0) (sqrt 1.5 / 2.0)) @?= True,+						testCase "tilt3y 0,0,-1 on (look 45 deg up from 30 deg right) gives (look 45 deg up from 30 deg right then yz %~ *i**3)" $+							--D.trace (printf "DEBUG0: left is %s and right is %s." (show $ updateit (tilt3ySimple (-up3) `mv3` (Vec3 (sqrt 2.0 / 4.0) (sqrt 1.5 / 2.0) (sqrt 2.0 / 2.0)))) (show $ (Vec3 (sqrt 2.0 / 4.0) (sqrt 1.5 / 2.0) (-sqrt 2.0 / 2.0)))) $+							(tilt3ySimple (-up3) `mv3` (Vec3 (sqrt 2.0 / 4.0) (sqrt 1.5 / 2.0) (sqrt 2.0 / 2.0))) `near3` (Vec3 (sqrt 2.0 / 4.0) (sqrt 2.0 / 2.0) (-sqrt 1.5 / 2.0)) @?= True+					],++				testGroup "tilt3z" $+					[+						testCase "tilt3z on 0,0,1 gives same result (look 45 deg up from 30 deg right)" $+							tilt3zSimple (Vec3 (sqrt 2.0 / 4.0) (sqrt 1.5 / 2.0) (sqrt 2.0 / 2.0)) `mv3` up3 @?= (Vec3 (sqrt 2.0 / 4.0) (sqrt 1.5 / 2.0) (sqrt 2.0 / 2.0)),+						testCase "tilt3z 0,0,1 on (look 45 deg up from 30 deg right) gives (look 45 deg up from 30 deg right) (no change)" $+							tilt3zSimple up3 `mv3` (Vec3 (sqrt 2.0 / 4.0) (sqrt 1.5 / 2.0) (sqrt 2.0 / 2.0)) @?= (Vec3 (sqrt 2.0 / 4.0) (sqrt 1.5 / 2.0) (sqrt 2.0 / 2.0)),+						-- Roll right a right angle.+						testCase "tilt3z 1,0,0 on (look 45 deg up from 30 deg right) gives (just xz %~ *i**3 of last test's expected)" $+							(tilt3zSimple right3 `mv3` (Vec3 (sqrt 2.0 / 4.0) (sqrt 1.5 / 2.0) (sqrt 2.0 / 2.0))) `near3` (Vec3 (sqrt 2.0 / 2.0) (sqrt 1.5 / 2.0) (-sqrt 2.0 / 4.0)) @?= True,+						testProperty "tilt3z == aimHoriz (yaw) <> rotateyz (pitch) (±aimVert by relUp) <> unaimHoriz (yaw) by near" $+							let v3normalize' v = v3normalize v `v3orWith` right3 in+							-- Apply a random up vector to a random position.+							\(relUp_ :: Vec3 Double) (randomPos :: Vec3 Double) ->+							let relUp = v3normalize' relUp_ `v3nsElse` up3 in+							-- Calculate the radians to aim right by with aimHoriz3DSimple.+							let yawRadiansRight = -(((relUp^.xy3) `v2nzElse` up2)^.t2 - up2^.t2) in+							-- Calculate the -radians to look down by.+							let pitchRadiansDown = acos $ relUp^.z3 in+							let pitchRadiansUp   = -pitchRadiansDown in++							-- Actual+							let byTilt3z = tilt3zSimple relUp `mv3` randomPos in++							-- Expected (by plane rotations)+							--let byYawPitch = aimHoriz3DSimple yawRadiansRight . aimVert3DSimple Nothing pitchRadiansUp . aimHoriz3DSimple (-yawRadiansRight) $ randomPos in  -- Incorrect result: can horizontally aim again.+							let byYawPitch = aimHoriz3DSimple yawRadiansRight . (\v -> rotateyzSimple (-pitchRadiansUp) `mv3` v) . aimHoriz3DSimple (-yawRadiansRight) $ randomPos in++							-- Optional debugging:+							--D.trace (printf "DEBUG0:\n\trelUp: %s\n\trandomPos: %s\n\tbyTilt3z: %s\n\tbyYawPitch: %s" (show $ relUp) (show $ randomPos) (show $ byTilt3z) (show $ byYawPitch)) $+							-- Optional verbose debugging:+							--D.trace (printf "DEBUG0:\n\trelUp: %s\n\trandomPos: %s\n\tbyTilt3z: %s\n\tbyYawPitch: %s\n\n\tyawRadiansRight: %s\n\tpitchRadiansUp: %s" (show $ relUp) (show $ randomPos) (show $ byTilt3z) (show $ byYawPitch) (show $ yawRadiansRight) (show $ pitchRadiansUp)) $++							byTilt3z `near3` byYawPitch+					]+			]+	]
+ Test/Immutaball/Share/Math/Orphans.hs view
@@ -0,0 +1,19 @@+{-# 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 #-}++{-# OPTIONS_GHC -Wno-orphans #-}++module Test.Immutaball.Share.Math.Orphans+	(+		--module Test.Immutaball.Share.Math.Core.Orphans+	) where++import Prelude ()+--import Immutaball.Prelude++import Test.Immutaball.Share.Math.Core.Orphans ()
+ Test/Immutaball/Share/Math/Test.hs view
@@ -0,0 +1,36 @@+{-# 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 #-}++module Test.Immutaball.Share.Math.Test+	(+		main,+		testsMain,+		tests+	) where++--import Test.HUnit+--import Test.QuickCheck+import Test.Tasty+--import Test.Tasty.HUnit hiding ((@?=), assertBool)+--import Test.Tasty.QuickCheck++import qualified Test.Immutaball.Share.Math.Core.Test+import qualified Test.Immutaball.Share.Math.X3D.Test++main :: IO ()+main = testsMain++testsMain :: IO ()+testsMain = defaultMain tests++tests :: TestTree+tests = testGroup "Immutaball.Share.Math" $+	[+		Test.Immutaball.Share.Math.Core.Test.tests,+		Test.Immutaball.Share.Math.X3D.Test.tests+	]
+ Test/Immutaball/Share/Math/X3D/Test.hs view
@@ -0,0 +1,134 @@+{-# 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 #-}++module Test.Immutaball.Share.Math.X3D.Test+	(+		main,+		testsMain,+		tests,++		simpleConstant,+		sampleLine0,+		sampleLine1,+		planeX1+	) where++--import Control.Arrow+--import Data.Functor.Identity++import Control.Lens+import Test.HUnit+--import Test.QuickCheck+import Test.Tasty+import Test.Tasty.HUnit hiding ((@?=), assertBool)+--import Test.Tasty.QuickCheck++import Immutaball.Share.Math+import Test.Immutaball.Share.Math.Core.Orphans ()++main :: IO ()+main = testsMain++testsMain :: IO ()+testsMain = defaultMain tests++simpleConstant :: Integer+simpleConstant = 3++sampleLine0 :: Line3 Double+sampleLine0 = line3Points (Vec3 0 0 0) (Vec3 1 1 0)++sampleLine1 :: Line3 Double+sampleLine1 = line3Points (Vec3 1 0 1) (Vec3 1 3 1)++planeX1 :: Plane3 Double+planeX1 = normalPlane3 (Vec3 1 0 0) 1++tests :: TestTree+tests = testGroup "Immutaball.Share.Math.X3D" $+	[+		testCase "simpleConstant == 3" $+			simpleConstant @?= 3,++		testGroup "plane3PointDistance" $+			[+				testCase "simple sample test" $+					(planeX1 `plane3PointDistance` Vec3 7 (-4) 88) `equivalentSmall` 6 @?= True+			],++		testGroup "pointToPlane" $+			[+				testCase "simple sample test" $+					(Vec3 7 (-4) 88 `pointToPlane` planeX1) `eq3` Vec3 1 (-4) 88 @?= True+			],++		testGroup "plane3ReflectPoint" $+			[+				testCase "simple sample test" $+					(planeX1 `plane3ReflectPoint` Vec3 7 (-4) 88) `eq3` Vec3 (-5) (-4) 88 @?= True+			],++		testGroup "normalizePlane3" $+			[+				testCase "simple sample test" $+					(Vec3 1 (-4) 88 `normalizePlane3` Vec3 1 0 0) `eqPlane3` planeX1 @?= True+			],++		testGroup "simple line3 tests" $+			[+				testCase "line3NormalizeDisplacement simple test" $+					(line3NormalizeDisplacement $ line3Points (Vec3 0 1 7) (Vec3 1 0 7)) `nearLine3` line3Points (Vec3 0.5 0.5 7) (Vec3 1.5 (-0.5) (7 :: Double)) @?= True,+				testCase "line3DistanceFromOrigin simple test" $+					(line3DistanceFromOrigin $ line3Points (Vec3 0 1 0) (Vec3 1 0 0)) `near` (1 / sqrt 2  :: Double) @?= True,++				testCase "line3Lerp simple test" $+					line3Lerp (line3Points (Vec3 1 2 3) (Vec3 2 4 4)) 3 `near3` Vec3 4 8 (6 :: Double) @?= True,++				testCase "line3CoordAtDistancePlane3 simple test" $+					((line3CoordAtDistancePlane3 planeX1 (line3Points (Vec3 9 824 4) (Vec3 7 (-1) 8)) 2 <&> equivalentSmall) <*> pure 3) @?= Just True,+				testCase "line3CoordAtDistancePlane3 parallel simple test" $+					((line3CoordAtDistancePlane3 planeX1 (line3Points (Vec3 9 824 4) (Vec3 9 (-1) 8)) 2 <&> equivalentSmall) <*> pure 3) @?= Nothing,++				testCase "line3PointCoord simple test" $+					line3PointCoord (line3Points (Vec3 1 1 2) (Vec3 1 8 2)) (Vec3 42 15 78) `equivalentSmall` ( 2 :: Double) @?= True,+				testCase "line3PointCoord negated simple test" $+					line3PointCoord (line3Points (Vec3 1 8 2) (Vec3 1 1 2)) (Vec3 42 15 78) `equivalentSmall` (-1 :: Double) @?= True,++				testCase "line3PointDistance 0 simple test" $+					line3PointDistance (line3Points (Vec3 1 1 2) (Vec3 1 8 2)) (Vec3 1 9   2) `equivalentSmall` (0 :: Double) @?= True,+				testCase "line3PointDistance non-0 simple test" $+					line3PointDistance (line3Points (Vec3 1 1 2) (Vec3 1 8 2)) (Vec3 1 123 3) `equivalentSmall` (1 :: Double) @?= True,++				testCase "line3DistanceCoordFromPoint simple test 0" $+					line3DistanceCoordFromPoint (line3Points (Vec3 1 1 2) (Vec3 1 8 2)) (Vec3 1 9 2) 0 `equivalentSmall` (0 :: Double) @?= True,+				testCase "line3DistanceCoordFromPoint simple test 1" $+					line3DistanceCoordFromPoint (line3Points (Vec3 1 1 2) (Vec3 1 8 2)) (Vec3 1 9 2) 1 `equivalentSmall` ((1/7) :: Double) @?= True,+				testCase "line3DistanceCoordFromPoint simple test 1 2" $+					line3DistanceCoordFromPoint (line3Points (Vec3 1 1 2) (Vec3 1 8 2)) (Vec3 2 9 2) 1 `equivalentSmall` (0 :: Double) @?= True,+				testCase "line3DistanceCoordFromPoint simple test 2" $+					line3DistanceCoordFromPoint (line3Points (Vec3 1 1 2) (Vec3 1 8 2)) (Vec3 2 9 2) 2 `equivalentSmall` ((sqrt 3 / 7) :: Double) @?= True+			],++		testGroup "line3 plane3 tests" $+			[+				testCase "plane3LineSegmentDistance behind simple test" $+					plane3LineSegmentDistance planeX1 (line3Points (Vec3 0 80 90) (Vec3 (-320) (-88) 777)) `near` (-1) @?= True,+				testCase "plane3LineSegmentDistance intersects simple test" $+					plane3LineSegmentDistance planeX1 (line3Points (Vec3 0 80 90) (Vec3 ( 320) (-88) 777)) `near` ( 0) @?= True,+				testCase "line3AxisReflectPlane3 simple test" $+					line3AxisReflectPlane3 (line3Points (Vec3 1 2 8) (Vec3 2 (-3) 7)) (planeX1^.abcp3) `nearLine3` line3Points (Vec3 1 2 8) (Vec3 0 (-3) 7) @?= True+			],++		testGroup "line3 line3 tests" $+			[+				testCase "sample lines are distance 1" $+					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+			]+	]
+ Test/Immutaball/Share/State/Fixtures.hs view
@@ -0,0 +1,124 @@+{-# 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 TemplateHaskell #-}++module Test.Immutaball.Share.State.Fixtures+	(+		withImmutaball,+		withImmutaball',+		exclusively,+		exclusivelyUnsafeMutex,+		ImmutaballFixture(..), ibfSDLManager,+		unsafeGlobalImmutaballFixture,+		unsafeGlobalImmutaballFixtureInitializerMutex,+		immutaballFixture,+		immutaballFixture',+		initializeImmutaballFixture,+		freeImmutaballFixture+	) where++import Prelude ()+import Immutaball.Prelude++import Control.Exception+import Control.Monad+import Data.Maybe++import Control.Concurrent.STM.TMVar+import Control.Lens+import Control.Monad.STM++import qualified Immutaball.Ball.CLI as CLI+import Immutaball.Share.Config+import Immutaball.Share.ImmutaballIO+import Immutaball.Share.SDLManager+import Immutaball.Share.State+import Immutaball.Share.Utils++import System.IO.Unsafe (unsafePerformIO)++-- ImmutaballFixture moved to fix TH errors.+data ImmutaballFixture = ImmutaballFixture {+	_ibfSDLManager :: Maybe SDLManagerHandle+}+makeLenses ''ImmutaballFixture++withImmutaball :: (TMVar a -> IBContext -> Immutaball) -> [String] -> IO a+withImmutaball = withImmutaball' True++withImmutaball' :: Bool -> (TMVar a -> IBContext -> Immutaball) -> [String] -> IO a+withImmutaball' headless immutaball extraArgs = do+	mout <- atomically $ newEmptyTMVar+	ibf <- immutaballFixture headless+	let x'cfg = defaultStaticConfig &+		x'cfgInitialWireWithCxt .~ Just (\cxt -> Just $ immutaball mout cxt) &+		x'cfgUseExistingSDLManager .~ (ibf^.ibfSDLManager)+	let args = if' headless ["--headless"] [] ++ extraArgs+	runImmutaballIO $ CLI.immutaballWithArgs x'cfg args+	out <- atomically $ takeTMVar mout+	return out++-- | Tasty provides no feature for mutually exclusive tests, but we only want+-- one SDL instance running at a time.+--+-- We would create a TMVar in a setup IO, but tasty does not seem to provide+-- this feature either unfortunately.+-- So just do it in the static context with unsafePerformIO.+exclusively :: IO a -> IO a+exclusively m = do+	() <- atomically $ takeTMVar exclusivelyUnsafeMutex+	m `finally` do+		atomically $ putTMVar exclusivelyUnsafeMutex ()++{-# NOINLINE exclusivelyUnsafeMutex #-}+exclusivelyUnsafeMutex :: TMVar ()+exclusivelyUnsafeMutex = unsafePerformIO $ newTMVarIO ()++-- ImmutaballFixture moved to fix TH errors.++{-# NOINLINE unsafeGlobalImmutaballFixture #-}+unsafeGlobalImmutaballFixture :: TMVar ImmutaballFixture+unsafeGlobalImmutaballFixture = unsafePerformIO $ newEmptyTMVarIO+{-# NOINLINE unsafeGlobalImmutaballFixtureInitializerMutex #-}+unsafeGlobalImmutaballFixtureInitializerMutex :: TMVar ()+unsafeGlobalImmutaballFixtureInitializerMutex = unsafePerformIO $ newTMVarIO ()++immutaballFixture :: Bool -> IO ImmutaballFixture+immutaballFixture = immutaballFixture' True++immutaballFixture' :: Bool -> Bool -> IO ImmutaballFixture+immutaballFixture' sharedSDLManager headless = do+	mibf <- atomically $ do+		() <- takeTMVar unsafeGlobalImmutaballFixtureInitializerMutex+		mibf <- tryReadTMVar unsafeGlobalImmutaballFixture+		when (isJust mibf) $ do+			putTMVar unsafeGlobalImmutaballFixtureInitializerMutex ()+		return mibf+	case mibf of+		Just ibf -> return ibf+		Nothing -> do+			ibf <- initializeImmutaballFixture sharedSDLManager headless+			atomically $ do+				writeTMVar unsafeGlobalImmutaballFixture ibf+				putTMVar unsafeGlobalImmutaballFixtureInitializerMutex ()+			return ibf++initializeImmutaballFixture :: Bool -> Bool -> IO ImmutaballFixture+initializeImmutaballFixture sharedSDLManager headless = do+	mhandle <- atomically $ newEmptyTMVar+	msdlManager <- if' (not sharedSDLManager) (return Nothing) $ do+		runImmutaballIO . initSDLManager headless $ \h -> mkAtomically (putTMVar mhandle h) $ \() -> mkEmptyIBIO+		atomically $ Just <$> takeTMVar mhandle+	return $ ImmutaballFixture {+		_ibfSDLManager = msdlManager+	}++freeImmutaballFixture :: ImmutaballFixture -> IO ()+freeImmutaballFixture ibf = do+	maybe (return ()) (runImmutaballIO . quitSDLManager) (ibf^.ibfSDLManager)+	return ()
+ Test/Immutaball/Share/State/Test.hs view
@@ -0,0 +1,152 @@+{-# 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 Arrows #-}++module Test.Immutaball.Share.State.Test+	(+		main,+		testsMain,+		tests,+		withFrameManager,++		trivialImmutaball,+		tenTimesImmutaball,+		holdingImmutaball,+		tenTimesCounterImmutaball,+		glImmutaball+	) where++import Control.Arrow++import Control.Concurrent.STM.TMVar+import Test.HUnit+--import Test.QuickCheck+import Test.Tasty+import Test.Tasty.HUnit hiding ((@?=), assertBool)+--import Test.Tasty.QuickCheck++--import Immutaball.Share.Context+import Immutaball.Share.ImmutaballIO+import Immutaball.Share.State+import Immutaball.Share.State.Context+import Immutaball.Share.Wire+import Immutaball.Share.Utils+import Test.Immutaball.Share.State.Fixtures++main :: IO ()+main = testsMain++testsMain :: IO ()+testsMain = defaultMain (tests False)++tests :: Bool -> TestTree+tests headless = testGroup "Immutaball.Share.State" $+	[+		testCase "init SDL (tinitSDL)" $ do+			_ <- immutaballFixture' sharedSDLManager headless+			return ()+	] +++	[+		afterInit . testCase "trivial is 3 (tSDLheadless)" . syncGLSDL $+			withImmutaball trivialImmutaball [] >>= (@?= 3),+		afterInit . testCase "tenTimes is 4 (tSDLheadless)" . syncGLSDL $+			withImmutaball tenTimesImmutaball [] >>= (@?= 4),+		afterInit . testCase "holding is 5 (tSDLheadless)" . syncGLSDL $+			withImmutaball holdingImmutaball [] >>= (@?= 5),+		afterInit . testCase "tenTimesCounter is 13 (tSDLheadless)" . syncGLSDL $+			withImmutaball tenTimesCounterImmutaball [] >>= (@?= 13)+	] ++ (if' headless [] $+	[+		after AllFinish "$NF ~ /tSDLheadless/" . afterInit . testCase "can hold a video context (SDLgl)" . exclusively' $+			withImmutaball' False glImmutaball [] >>= (@?= ())+	]) +++	[+		withFrameManager headless "id frame manager: " id,+		withFrameManager headless "immutaballMultiToSingle: " (fromImmutaballSingle' . immutaballMultiToSingle'),+		withFrameManager headless "immutaballSigleToMulti: "  (fromImmutaballMulti'  . immutaballSingleToMulti'),++		testGroup "test mfix works" $+			[+				withFrameManager headless "loopWire . first: " (loopWire . first)+			]+	] +++	[+		after AllFinish "$NF ~ /tSDL/" . testCase "clean up SDL (tfinishSDL)" $+			immutaballFixture headless >>= freeImmutaballFixture+	]+	where+		sharedSDLManager :: Bool+		sharedSDLManager = True+		syncGLSDL = if' sharedSDLManager id (if' headless id exclusively')+		afterInit = after AllFinish "$NF ~ /tinitSDL/"+		exclusively' = if' sharedSDLManager id exclusively++withFrameManager :: (Applicative t) =>+	Bool ->+	String ->+	(+		Wire ImmutaballM (t Request)  (t Response) ->+		Wire ImmutaballM RequestFrame ResponseFrame+	) ->+	TestTree+withFrameManager headless prefix frameManager =+	testGroup (prefix ++ " immutaball wire tests with frame manager") $+		[+			afterInit . testCase (prefix ++ "trivial is 3 (tSDLheadless)") . syncGLSDL $+				withImmutaball ((frameManager .) . trivialImmutaball) [] >>= (@?= 3),+			afterInit . testCase (prefix ++ "tenTimes is 4 (tSDLheadless)") . syncGLSDL $+				withImmutaball ((frameManager .) . tenTimesImmutaball) [] >>= (@?= 4),+			afterInit . testCase (prefix ++ "holding is 5 (tSDLheadless)") . syncGLSDL $+				withImmutaball ((frameManager .) . holdingImmutaball) [] >>= (@?= 5),+			afterInit . testCase (prefix ++ "tenTimesCounter is 13 (tSDLheadless)") . syncGLSDL $+				withImmutaball ((frameManager .) . tenTimesCounterImmutaball) [] >>= (@?= 13)+		] ++ (if' headless [] $+		[+			after AllFinish "$NF ~ /tSDLheadless/" . afterInit . testCase "can hold a video context (SDLgl)" . exclusively' $+				withImmutaball' False ((frameManager .) . glImmutaball) [] >>= (@?= ())+		])+	where+		sharedSDLManager :: Bool+		sharedSDLManager = True+		syncGLSDL = if' sharedSDLManager id (if' headless id exclusively')+		afterInit = after AllFinish "$NF ~ /tinitSDL/"+		exclusively' = if' sharedSDLManager id exclusively++--trivialImmutaball :: TMVar Integer -> IBContext -> Immutaball+trivialImmutaball :: (Applicative t) => TMVar Integer -> IBContext -> Wire ImmutaballM (t Request) (t Response)+trivialImmutaball mout _cxt0 = proc _request -> do+	_ <- monadic -< liftIBIO $ Atomically (putTMVar mout 3) id+	returnA -< pure DoneResponse++tenTimesImmutaball :: (Applicative t) => TMVar Integer -> IBContext -> Wire ImmutaballM (t Request) (t Response)+tenTimesImmutaball mout _cxt0 = proc _request -> do+	_ <- monadic -< liftIBIO $ Atomically (writeTMVar mout 4) id+	delayNI 9 (pure ContinueResponse) -< pure DoneResponse++holdingImmutaball :: (Applicative t) => TMVar Integer -> IBContext -> Wire ImmutaballM (t Request) (t Response)+holdingImmutaball mout _cxt0 = proc _requests -> do+	x <- hold 5 -< Nothing+	_ <- monadic -< liftIBIO $ Atomically (writeTMVar mout x) id+	delayNI 9 (pure ContinueResponse) -< pure DoneResponse++tenTimesCounterImmutaball :: (Applicative t) => TMVar Integer -> IBContext -> Wire ImmutaballM (t Request) (t Response)+tenTimesCounterImmutaball mout _cxt0 = proc _requests -> do+	_ <- monadic <<< delay (liftIBIO $ Atomically (putTMVar mout 3) id) <<< constWire (liftIBIO $ pure ()) -< ()+	x <- monadic -< liftIBIO $ Atomically (takeTMVar mout) id+	_ <- monadic -< liftIBIO $ Atomically (putTMVar mout (x+1)) id+	delayNI 9 (pure ContinueResponse) -< pure DoneResponse++glImmutaball :: (Applicative t) => TMVar () -> IBContext -> Wire ImmutaballM (t Request) (t Response)+glImmutaball mout baseCxt0 = proc _requests -> do+	_ <- monadic -< liftIBIO $ Atomically (writeTMVar mout ()) id+	rec+		cxtLast <- delay cxt0 -< cxt+		cxtn <- requireVideo -< cxtLast+		cxt <- returnA -< cxtn+	delayNI 9 (pure ContinueResponse) -< pure DoneResponse+	where cxt0 = initialStateCxt baseCxt0
+ Test/Immutaball/Share/Wire/Test.hs view
@@ -0,0 +1,165 @@+{-# 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 Arrows #-}++module Test.Immutaball.Share.Wire.Test+	(+		main,+		testsMain,+		tests,++		myWire,+		dt,+		accumulateThings,+		differentiateThings,+		stepFourTimes,+		stepThrice,+		stepTwice,+		stepOnce,+		waitThenEmit,+		holdingWire,+		queueingWire+	) where++import Control.Arrow+import Data.Functor.Identity++import Test.HUnit+--import Test.QuickCheck+import Test.Tasty+import Test.Tasty.HUnit hiding ((@?=), assertBool)+--import Test.Tasty.QuickCheck++import Immutaball.Share.Wire++main :: IO ()+main = testsMain++testsMain :: IO ()+testsMain = defaultMain tests++myWire :: Wire Identity () Integer+myWire = proc () -> returnA -< 3++dt :: Wire Identity () Integer+dt = proc () -> returnA -< 100++accumulateThings :: Wire Identity () Integer+accumulateThings = proc () -> do+	dt_ <- dt -< ()+	thing <- myWire -< ()+	integrate 0 -< thing * dt_++differentiateThings :: Wire Identity () Integer+differentiateThings = proc () -> do+	dt_ <- dt -< ()+	thing <- myWire -< ()+	differentiate -< thing * dt_++stepFourTimes :: Wire Identity () a -> a+stepFourTimes w0 =+	let+		(Identity (_y0,  w1)) = stepWire w0 ()+		(Identity (_y1,  w2)) = stepWire w1 ()+		(Identity (_y2,  w3)) = stepWire w2 ()+		(Identity ( y3, _w4)) = stepWire w3 ()++		result = y3+	in+		result++stepThrice :: Wire Identity () a -> a+stepThrice w0 =+	let+		(Identity (_y0,  w1)) = stepWire w0 ()+		(Identity (_y1,  w2)) = stepWire w1 ()+		(Identity ( y2, _w3)) = stepWire w2 ()++		result = y2+	in+		result++stepTwice :: Wire Identity () a -> a+stepTwice w0 =+	let+		(Identity (_y0,  w1)) = stepWire w0 ()+		(Identity ( y1, _w2)) = stepWire w1 ()++		result = y1+	in+		result++stepOnce :: Wire Identity () a -> a+stepOnce w0 =+	let+		(Identity (y0, _w1)) = stepWire w0 ()++		result = y0+	in+		result++waitThenEmit :: Wire Identity () (Maybe Integer)+waitThenEmit = proc () -> do+	rec out <- delay Nothing -< Just 3+	returnA -< out++holdingWire :: Wire Identity () Integer+holdingWire = proc () -> do+	couldBe <- waitThenEmit -< ()+	lastIs <- hold 1 -< couldBe+	returnA -< lastIs++queueingWire :: Wire Identity () (Maybe Integer)+queueingWire = proc () -> do+	pump <- delay [2,3,1] -< returnA []+	queue -< pump++tests :: TestTree+tests = testGroup "Immutaball.Share.Wire" $+	[+		testGroup "integrate / device tests" $+			[+				testCase "integrate twice" $+					stepThrice accumulateThings @?= 600,+				testCase "differentiate twice" $+					stepThrice differentiateThings @?= 0,+				testCase "differentiate once" $+					stepTwice differentiateThings @?= 0,+				testCase "differentiate never" $+					stepOnce differentiateThings @?= 0+			],++		testGroup "other utils tests" $+			let i = id :: Integer -> Integer in+			[+				testCase "hold thrice" $+					stepThrice holdingWire @?= 3,+				testCase "hold twice" $+					stepTwice holdingWire @?= 3,+				testCase "hold once" $+					stepOnce holdingWire @?= 1,++				testCase "queue four times" $+					stepFourTimes queueingWire @?= Nothing,+				testCase "queue thrice" $+					stepThrice queueingWire @?= Just 1,+				testCase "queue twice" $+					stepTwice queueingWire @?= Just 3,+				testCase "queue once" $+					stepOnce queueingWire @?= Just 2,++				testCase "delayNI 2 once" $+					stepOnce      (delayNI 2 7 <<< constWire 3) @?= i 7,+				testCase "delayNI 2 twice" $+					stepTwice     (delayNI 2 7 <<< constWire 3) @?= i 7,+				testCase "delayNI 2 thrice" $+					stepThrice    (delayNI 2 7 <<< constWire 3) @?= i 3,+				testCase "delayNI 2 four times" $+					stepFourTimes (delayNI 2 7 <<< constWire 3) @?= i 3+			]+	]
+ Test/Immutaball/Test.hs view
@@ -0,0 +1,38 @@+{-# 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 #-}++module Test.Immutaball.Test+	(+		main,+		testsMain,+		tests+	) where++--import Test.HUnit+--import Test.QuickCheck+import Test.Tasty+--import Test.Tasty.HUnit hiding ((@?=), assertBool)+--import Test.Tasty.QuickCheck++import qualified Test.Immutaball.Share.Math.Test+import qualified Test.Immutaball.Share.State.Test+import qualified Test.Immutaball.Share.Wire.Test++main :: IO ()+main = testsMain++testsMain :: IO ()+testsMain = defaultMain (tests False)++tests :: Bool -> TestTree+tests headless = testGroup "Immutaball" $+	[+		Test.Immutaball.Share.Wire.Test.tests,+		Test.Immutaball.Share.State.Test.tests headless,+		Test.Immutaball.Share.Math.Test.tests+	]
+ doc/legal/license-0BSD.txt view
@@ -0,0 +1,3 @@+Permission to use, copy, modify, and/or distribute this software for any purpose with or without fee is hereby granted.++THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ doc/legal/license-DejaVu.txt view
@@ -0,0 +1,99 @@+Fonts are (c) Bitstream (see below). DejaVu changes are in public domain.+Glyphs imported from Arev fonts are (c) Tavmjong Bah (see below)++Bitstream Vera Fonts Copyright+------------------------------++Copyright (c) 2003 by Bitstream, Inc. All Rights Reserved. Bitstream Vera is+a trademark of Bitstream, Inc.++Permission is hereby granted, free of charge, to any person obtaining a copy+of the fonts accompanying this license ("Fonts") and associated+documentation files (the "Font Software"), to reproduce and distribute the+Font Software, including without limitation the rights to use, copy, merge,+publish, distribute, and/or sell copies of the Font Software, and to permit+persons to whom the Font Software is furnished to do so, subject to the+following conditions:++The above copyright and trademark notices and this permission notice shall+be included in all copies of one or more of the Font Software typefaces.++The Font Software may be modified, altered, or added to, and in particular+the designs of glyphs or characters in the Fonts may be modified and+additional glyphs or characters may be added to the Fonts, only if the fonts+are renamed to names not containing either the words "Bitstream" or the word+"Vera".++This License becomes null and void to the extent applicable to Fonts or Font+Software that has been modified and is distributed under the "Bitstream+Vera" names.++The Font Software may be sold as part of a larger software package but no+copy of one or more of the Font Software typefaces may be sold by itself.++THE FONT SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS+OR IMPLIED, INCLUDING BUT NOT LIMITED TO ANY WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT OF COPYRIGHT, PATENT,+TRADEMARK, OR OTHER RIGHT. IN NO EVENT SHALL BITSTREAM OR THE GNOME+FOUNDATION BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, INCLUDING+ANY GENERAL, SPECIAL, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL DAMAGES,+WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF+THE USE OR INABILITY TO USE THE FONT SOFTWARE OR FROM OTHER DEALINGS IN THE+FONT SOFTWARE.++Except as contained in this notice, the names of Gnome, the Gnome+Foundation, and Bitstream Inc., shall not be used in advertising or+otherwise to promote the sale, use or other dealings in this Font Software+without prior written authorization from the Gnome Foundation or Bitstream+Inc., respectively. For further information, contact: fonts at gnome dot+org. ++Arev Fonts Copyright+------------------------------++Copyright (c) 2006 by Tavmjong Bah. All Rights Reserved.++Permission is hereby granted, free of charge, to any person obtaining+a copy of the fonts accompanying this license ("Fonts") and+associated documentation files (the "Font Software"), to reproduce+and distribute the modifications to the Bitstream Vera Font Software,+including without limitation the rights to use, copy, merge, publish,+distribute, and/or sell copies of the Font Software, and to permit+persons to whom the Font Software is furnished to do so, subject to+the following conditions:++The above copyright and trademark notices and this permission notice+shall be included in all copies of one or more of the Font Software+typefaces.++The Font Software may be modified, altered, or added to, and in+particular the designs of glyphs or characters in the Fonts may be+modified and additional glyphs or characters may be added to the+Fonts, only if the fonts are renamed to names not containing either+the words "Tavmjong Bah" or the word "Arev".++This License becomes null and void to the extent applicable to Fonts+or Font Software that has been modified and is distributed under the +"Tavmjong Bah Arev" names.++The Font Software may be sold as part of a larger software package but+no copy of one or more of the Font Software typefaces may be sold by+itself.++THE FONT SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO ANY WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT+OF COPYRIGHT, PATENT, TRADEMARK, OR OTHER RIGHT. IN NO EVENT SHALL+TAVMJONG BAH BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,+INCLUDING ANY GENERAL, SPECIAL, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL+DAMAGES, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING+FROM, OUT OF THE USE OR INABILITY TO USE THE FONT SOFTWARE OR FROM+OTHER DEALINGS IN THE FONT SOFTWARE.++Except as contained in this notice, the name of Tavmjong Bah shall not+be used in advertising or otherwise to promote the sale, use or other+dealings in this Font Software without prior written authorization+from Tavmjong Bah. For further information, contact: tavmjong @ free+. fr.++$Id: LICENSE 2133 2007-11-28 02:46:28Z lechimp $
+ doc/legal/license-GPL-2.0.txt view
@@ -0,0 +1,350 @@+		    GNU GENERAL PUBLIC LICENSE+		       Version 2, June 1991++ Copyright (C) 1989, 1991 Free Software Foundation, Inc.+               59 Temple Place, Suite 330, Boston, MA  02111-1307  USA++Everyone is permitted  to copy and distribute verbatim  copies of this+license document, but changing it is not allowed.++			    Preamble++  The  licenses for  most  software  are designed  to  take away  your+freedom to share  and change it.  By contrast,  the GNU General Public+License is intended to guarantee your freedom to share and change free+software--to make sure  the software is free for  all its users.  This+General  Public   License  applies  to  most  of   the  Free  Software+Foundation's software and to any other program whose authors commit to+using it.  (Some other Free Software Foundation software is covered by+the GNU Library General Public  License instead.)  You can apply it to+your programs, too.++  When we  speak of  free software, we  are referring to  freedom, not+price.  Our General Public Licenses are designed to make sure that you+have the freedom to distribute copies of free software (and charge for+this service if you wish), that  you receive source code or can get it+if you want it,  that you can change the software or  use pieces of it+in new free programs; and that you know you can do these things.++  To protect  your rights,  we need to  make restrictions  that forbid+anyone to deny you these rights or to ask you to surrender the rights.+These restrictions  translate to  certain responsibilities for  you if+you distribute copies of the software, or if you modify it.++  For example,  if you  distribute copies of  such a  program, whether+gratis or for a fee, you  must give the recipients all the rights that+you have.  You  must make sure that they, too, receive  or can get the+source code.   And you must show  them these terms so  they know their+rights.++  We protect your  rights with two steps: (1)  copyright the software,+and (2)  offer you  this license which  gives you legal  permission to+copy, distribute and/or modify the software.++  Also, for each author's protection and ours, we want to make certain+that  everyone understands  that there  is no  warranty for  this free+software.  If the software is  modified by someone else and passed on,+we  want  its recipients  to  know  that what  they  have  is not  the+original, so that  any problems introduced by others  will not reflect+on the original authors' reputations.++  Finally,  any  free program  is  threatened  constantly by  software+patents.  We  wish to avoid the  danger that redistributors  of a free+program will individually obtain patent licenses, in effect making the+program proprietary.  To prevent this,  we have made it clear that any+patent must  be licensed  for everyone's free  use or not  licensed at+all.++  The  precise  terms and  conditions  for  copying, distribution  and+modification follow.++		    GNU GENERAL PUBLIC LICENSE+   TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION++  0. This License applies to any  program or other work which contains+a notice placed  by the copyright holder saying  it may be distributed+under the terms of this General Public License.  The "Program", below,+refers to any such program or  work, and a "work based on the Program"+means either the  Program or any derivative work  under copyright law:+that is  to say,  a work containing  the Program  or a portion  of it,+either verbatim  or with modifications and/or  translated into another+language.  (Hereinafter, translation is included without limitation in+the term "modification".)  Each licensee is addressed as "you".++Activities other  than copying, distribution and  modification are not+covered  by this  License; they  are outside  its scope.   The  act of+running the Program is not restricted, and the output from the Program+is covered only if its contents constitute a work based on the Program+(independent  of having been  made by  running the  Program).  Whether+that is true depends on what the Program does.++  1. You  may copy  and distribute  verbatim copies  of  the Program's+source  code as  you  receive it,  in  any medium,  provided that  you+conspicuously and  appropriately publish  on each copy  an appropriate+copyright  notice and  disclaimer  of warranty;  keep  intact all  the+notices that refer to this License and to the absence of any warranty;+and give  any other recipients of  the Program a copy  of this License+along with the Program.++You may charge a fee for  the physical act of transferring a copy, and+you may  at your  option offer warranty  protection in exchange  for a+fee.++  2. You may modify your copy or  copies of the Program or any portion+of  it,  thus forming  a  work  based on  the  Program,  and copy  and+distribute such  modifications or  work under the  terms of  Section 1+above, provided that you also meet all of these conditions:++    a) You  must cause the  modified files to carry  prominent notices+    stating that you changed the files and the date of any change.++    b) You must cause any work that you distribute or publish, that in+    whole or  in part contains or  is derived from the  Program or any+    part thereof, to be licensed as  a whole at no charge to all third+    parties under the terms of this License.++    c) If  the modified program normally  reads commands interactively+    when  run,  you must  cause  it,  when  started running  for  such+    interactive use in  the most ordinary way, to  print or display an+    announcement  including  an  appropriate  copyright notice  and  a+    notice that there is no warranty (or else, saying that you provide+    a  warranty) and  that users  may redistribute  the  program under+    these conditions, and telling the user  how to view a copy of this+    License.   (Exception: if  the Program  itself is  interactive but+    does not normally  print such an announcement, your  work based on+    the Program is not required to print an announcement.)++These  requirements  apply  to  the  modified work  as  a  whole.   If+identifiable sections of  that work are not derived  from the Program,+and  can be reasonably  considered independent  and separate  works in+themselves, then  this License, and its  terms, do not  apply to those+sections when  you distribute  them as separate  works.  But  when you+distribute the same sections as part  of a whole which is a work based+on the Program, the distribution of  the whole must be on the terms of+this  License, whose  permissions for  other licensees  extend  to the+entire whole, and thus to each  and every part regardless of who wrote+it.++Thus, it is not the intent  of this section to claim rights or contest+your rights to work written entirely  by you; rather, the intent is to+exercise  the  right to  control  the  distribution  of derivative  or+collective works based on the Program.++In addition, mere aggregation of another work not based on the Program+with the Program (or with a work  based on the Program) on a volume of+a storage or  distribution medium does not bring  the other work under+the scope of this License.++  3. You may copy  and distribute the Program (or a  work based on it,+under Section 2) in object code  or executable form under the terms of+Sections 1 and 2 above provided that you also do one of the following:++    a) Accompany  it with the  complete corresponding machine-readable+    source code, which must be distributed under the terms of Sections+    1  and  2  above  on   a  medium  customarily  used  for  software+    interchange; or,++    b) Accompany  it with  a written offer,  valid for at  least three+    years, to  give any third  party, for a  charge no more  than your+    cost  of  physically performing  source  distribution, a  complete+    machine-readable  copy of  the  corresponding source  code, to  be+    distributed under the terms of Sections  1 and 2 above on a medium+    customarily used for software interchange; or,++    c) Accompany it with the  information you received as to the offer+    to  distribute corresponding  source code.   (This  alternative is+    allowed  only  for  noncommercial  distribution and  only  if  you+    received the program  in object code or executable  form with such+    an offer, in accord with Subsection b above.)++The source  code for a work means  the preferred form of  the work for+making modifications  to it.  For an executable  work, complete source+code means all  the source code for all modules  it contains, plus any+associated  interface  definition  files,  plus the  scripts  used  to+control compilation and installation of the executable.  However, as a+special  exception,  the  source  code distributed  need  not  include+anything  that is  normally distributed  (in either  source  or binary+form) with the  major components (compiler, kernel, and  so on) of the+operating system  on which the executable runs,  unless that component+itself accompanies the executable.++If  distribution of  executable or  object  code is  made by  offering+access  to copy  from  a designated  place,  then offering  equivalent+access  to  copy  the  source  code  from the  same  place  counts  as+distribution of  the source  code, even though  third parties  are not+compelled to copy the source along with the object code.++  4. You may  not copy, modify, sublicense, or  distribute the Program+except  as  expressly  provided   under  this  License.   Any  attempt+otherwise  to copy, modify,  sublicense or  distribute the  Program is+void, and will automatically terminate your rights under this License.+However, parties who  have received copies, or rights,  from you under+this License will  not have their licenses terminated  so long as such+parties remain in full compliance.++  5. You are not  required to accept this License,  since you have not+signed it.  However,  nothing else grants you permission  to modify or+distribute  the Program or  its derivative  works.  These  actions are+prohibited by  law if you do  not accept this  License.  Therefore, by+modifying  or distributing  the  Program  (or any  work  based on  the+Program), you indicate  your acceptance of this License  to do so, and+all its  terms and conditions  for copying, distributing  or modifying+the Program or works based on it.++  6. Each time you redistribute the  Program (or any work based on the+Program),  the recipient  automatically  receives a  license from  the+original licensor to copy, distribute or modify the Program subject to+these  terms   and  conditions.   You  may  not   impose  any  further+restrictions on the recipients' exercise of the rights granted herein.+You are not  responsible for enforcing compliance by  third parties to+this License.++  7. If, as a consequence of  a court judgment or allegation of patent+infringement or for  any other reason (not limited  to patent issues),+conditions are  imposed on you  (whether by court order,  agreement or+otherwise) that contradict the conditions of this License, they do not+excuse  you  from the  conditions  of  this  License.  If  you  cannot+distribute so as to satisfy simultaneously your obligations under this+License and any other pertinent obligations, then as a consequence you+may  not distribute  the Program  at all.   For example,  if  a patent+license would not permit royalty-free redistribution of the Program by+all those who receive copies  directly or indirectly through you, then+the only  way you could satisfy both  it and this License  would be to+refrain entirely from distribution of the Program.++If any portion of this  section is held invalid or unenforceable under+any particular circumstance, the balance of the section is intended to+apply  and the  section  as a  whole  is intended  to  apply in  other+circumstances.++It is  not the purpose of this  section to induce you  to infringe any+patents or other  property right claims or to  contest validity of any+such  claims; this  section has  the  sole purpose  of protecting  the+integrity  of   the  free  software  distribution   system,  which  is+implemented  by  public  license  practices.  Many  people  have  made+generous  contributions  to the  wide  range  of software  distributed+through  that system  in reliance  on consistent  application  of that+system; it is up to the author/donor to decide if he or she is willing+to distribute software through any  other system and a licensee cannot+impose that choice.++This section is intended to  make thoroughly clear what is believed to+be a consequence of the rest of this License.++  8. If the  distribution and/or use  of the Program is  restricted in+certain countries either by  patents or by copyrighted interfaces, the+original copyright  holder who places  the Program under  this License+may  add an  explicit geographical  distribution  limitation excluding+those countries,  so that distribution  is permitted only in  or among+countries not thus excluded.   In such case, this License incorporates+the limitation as if written in the body of this License.++  9. The  Free  Software Foundation  may  publish  revised and/or  new+versions of  the General Public License  from time to  time.  Such new+versions will  be similar  in spirit to  the present version,  but may+differ in detail to address new problems or concerns.++Each version is given a distinguishing version number.  If the Program+specifies a  version number  of this License  which applies to  it and+"any later  version", you have the  option of following  the terms and+conditions either of that version or of any later version published by+the  Free Software  Foundation.  If  the  Program does  not specify  a+version  number of  this  License,  you may  choose  any version  ever+published by the Free Software Foundation.++  10. If you wish to incorporate  parts of the Program into other free+programs  whose distribution  conditions are  different, write  to the+author to  ask for permission.   For software which is  copyrighted by+the Free  Software Foundation, write to the  Free Software Foundation;+we sometimes make exceptions for this.  Our decision will be guided by+the two goals of preserving the  free status of all derivatives of our+free  software and  of promoting  the  sharing and  reuse of  software+generally.++			    NO WARRANTY++  11. BECAUSE  THE PROGRAM  IS LICENSED  FREE OF  CHARGE, THERE  IS NO+WARRANTY FOR THE  PROGRAM, TO THE EXTENT PERMITTED  BY APPLICABLE LAW.+EXCEPT WHEN  OTHERWISE STATED IN WRITING THE  COPYRIGHT HOLDERS AND/OR+OTHER  PARTIES PROVIDE  THE PROGRAM  "AS IS"  WITHOUT WARRANTY  OF ANY+KIND, EITHER EXPRESSED OR IMPLIED,  INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED  WARRANTIES OF  MERCHANTABILITY AND  FITNESS FOR  A PARTICULAR+PURPOSE.  THE  ENTIRE RISK  AS TO THE  QUALITY AND PERFORMANCE  OF THE+PROGRAM IS WITH  YOU.  SHOULD THE PROGRAM PROVE  DEFECTIVE, YOU ASSUME+THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION.++  12. IN NO  EVENT UNLESS REQUIRED BY  APPLICABLE LAW OR  AGREED TO IN+WRITING WILL ANY  COPYRIGHT HOLDER, OR ANY OTHER  PARTY WHO MAY MODIFY+AND/OR REDISTRIBUTE THE  PROGRAM AS PERMITTED ABOVE, BE  LIABLE TO YOU+FOR   DAMAGES,   INCLUDING  ANY   GENERAL,   SPECIAL,  INCIDENTAL   OR+CONSEQUENTIAL DAMAGES ARISING  OUT OF THE USE OR  INABILITY TO USE THE+PROGRAM  (INCLUDING BUT  NOT LIMITED  TO LOSS  OF DATA  OR  DATA BEING+RENDERED INACCURATE OR  LOSSES SUSTAINED BY YOU OR  THIRD PARTIES OR A+FAILURE OF  THE PROGRAM TO OPERATE  WITH ANY OTHER  PROGRAMS), EVEN IF+SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH+DAMAGES.++		     END OF TERMS AND CONDITIONS++	    How to Apply These Terms to Your New Programs++  If you develop a new program, and  you want it to be of the greatest+possible use to the public, the best way to achieve this is to make it+free software  which everyone can redistribute and  change under these+terms.++  To do so, attach the following notices to the program.  It is safest+to attach  them to the start  of each source file  to most effectively+convey the exclusion  of warranty; and each file  should have at least+the "copyright" line and a pointer to where the full notice is found.++    <one line to give the program's name and a brief idea of what it does.>+    Copyright (C) <year>  <name of author>++    This  program is  free software;  you can  redistribute  it and/or+    modify it  under the  terms of the  GNU General Public  License as+    published by the Free Software Foundation; either version 2 of the+    License, or (at your option) any later version.++    This program  is distributed in the  hope that it  will be useful,+    but  WITHOUT ANY WARRANTY;  without even  the implied  warranty of+    MERCHANTABILITY or FITNESS FOR  A PARTICULAR PURPOSE.  See the GNU+    General Public License for more details.++    You should have received a  copy of the GNU General Public License+    along  with this  program;  if  not, write  to  the Free  Software+    Foundation,  Inc.,   59  Temple  Place,  Suite   330,  Boston,  MA+    02111-1307 USA+++Also add information on how to contact you by electronic and paper mail.++If  the program is  interactive, make  it output  a short  notice like+this when it starts in an interactive mode:++    Gnomovision version 69, Copyright (C) year name of author+    Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.+    This is free software, and you are welcome to redistribute it+    under certain conditions; type `show c' for details.++The  hypothetical commands  `show  w'  and `show  c'  should show  the+appropriate  parts of  the  General Public  License.   Of course,  the+commands you use may be called something other than `show w' and `show+c'; they could even be mouse-clicks or menu items--whatever suits your+program.++You should  also get your  employer (if you  work as a  programmer) or+your school, if any, to sign a "copyright disclaimer" for the program,+if necessary.  Here is a sample; alter the names:++  Yoyodyne, Inc., hereby disclaims all copyright interest in the program+  `Gnomovision' (which makes passes at compilers) written by James Hacker.++  <signature of Ty Coon>, 1 April 1989+  Ty Coon, President of Vice++This General Public License does not permit incorporating your program+into proprietary  programs.  If your program is  a subroutine library,+you  may  consider  it  more  useful  to  permit  linking  proprietary+applications with  the library.  If this  is what you want  to do, use+the GNU Library General Public License instead of this License.
+ doc/legal/license-GPL-3.0.txt view
@@ -0,0 +1,674 @@+                    GNU GENERAL PUBLIC LICENSE+                       Version 3, 29 June 2007++ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.++                            Preamble++  The GNU General Public License is a free, copyleft license for+software and other kinds of works.++  The licenses for most software and other practical works are designed+to take away your freedom to share and change the works.  By contrast,+the GNU General Public License is intended to guarantee your freedom to+share and change all versions of a program--to make sure it remains free+software for all its users.  We, the Free Software Foundation, use the+GNU General Public License for most of our software; it applies also to+any other work released this way by its authors.  You can apply it to+your programs, too.++  When we speak of free software, we are referring to freedom, not+price.  Our General Public Licenses are designed to make sure that you+have the freedom to distribute copies of free software (and charge for+them if you wish), that you receive source code or can get it if you+want it, that you can change the software or use pieces of it in new+free programs, and that you know you can do these things.++  To protect your rights, we need to prevent others from denying you+these rights or asking you to surrender the rights.  Therefore, you have+certain responsibilities if you distribute copies of the software, or if+you modify it: responsibilities to respect the freedom of others.++  For example, if you distribute copies of such a program, whether+gratis or for a fee, you must pass on to the recipients the same+freedoms that you received.  You must make sure that they, too, receive+or can get the source code.  And you must show them these terms so they+know their rights.++  Developers that use the GNU GPL protect your rights with two steps:+(1) assert copyright on the software, and (2) offer you this License+giving you legal permission to copy, distribute and/or modify it.++  For the developers' and authors' protection, the GPL clearly explains+that there is no warranty for this free software.  For both users' and+authors' sake, the GPL requires that modified versions be marked as+changed, so that their problems will not be attributed erroneously to+authors of previous versions.++  Some devices are designed to deny users access to install or run+modified versions of the software inside them, although the manufacturer+can do so.  This is fundamentally incompatible with the aim of+protecting users' freedom to change the software.  The systematic+pattern of such abuse occurs in the area of products for individuals to+use, which is precisely where it is most unacceptable.  Therefore, we+have designed this version of the GPL to prohibit the practice for those+products.  If such problems arise substantially in other domains, we+stand ready to extend this provision to those domains in future versions+of the GPL, as needed to protect the freedom of users.++  Finally, every program is threatened constantly by software patents.+States should not allow patents to restrict development and use of+software on general-purpose computers, but in those that do, we wish to+avoid the special danger that patents applied to a free program could+make it effectively proprietary.  To prevent this, the GPL assures that+patents cannot be used to render the program non-free.++  The precise terms and conditions for copying, distribution and+modification follow.++                       TERMS AND CONDITIONS++  0. Definitions.++  "This License" refers to version 3 of the GNU General Public License.++  "Copyright" also means copyright-like laws that apply to other kinds of+works, such as semiconductor masks.++  "The Program" refers to any copyrightable work licensed under this+License.  Each licensee is addressed as "you".  "Licensees" and+"recipients" may be individuals or organizations.++  To "modify" a work means to copy from or adapt all or part of the work+in a fashion requiring copyright permission, other than the making of an+exact copy.  The resulting work is called a "modified version" of the+earlier work or a work "based on" the earlier work.++  A "covered work" means either the unmodified Program or a work based+on the Program.++  To "propagate" a work means to do anything with it that, without+permission, would make you directly or secondarily liable for+infringement under applicable copyright law, except executing it on a+computer or modifying a private copy.  Propagation includes copying,+distribution (with or without modification), making available to the+public, and in some countries other activities as well.++  To "convey" a work means any kind of propagation that enables other+parties to make or receive copies.  Mere interaction with a user through+a computer network, with no transfer of a copy, is not conveying.++  An interactive user interface displays "Appropriate Legal Notices"+to the extent that it includes a convenient and prominently visible+feature that (1) displays an appropriate copyright notice, and (2)+tells the user that there is no warranty for the work (except to the+extent that warranties are provided), that licensees may convey the+work under this License, and how to view a copy of this License.  If+the interface presents a list of user commands or options, such as a+menu, a prominent item in the list meets this criterion.++  1. Source Code.++  The "source code" for a work means the preferred form of the work+for making modifications to it.  "Object code" means any non-source+form of a work.++  A "Standard Interface" means an interface that either is an official+standard defined by a recognized standards body, or, in the case of+interfaces specified for a particular programming language, one that+is widely used among developers working in that language.++  The "System Libraries" of an executable work include anything, other+than the work as a whole, that (a) is included in the normal form of+packaging a Major Component, but which is not part of that Major+Component, and (b) serves only to enable use of the work with that+Major Component, or to implement a Standard Interface for which an+implementation is available to the public in source code form.  A+"Major Component", in this context, means a major essential component+(kernel, window system, and so on) of the specific operating system+(if any) on which the executable work runs, or a compiler used to+produce the work, or an object code interpreter used to run it.++  The "Corresponding Source" for a work in object code form means all+the source code needed to generate, install, and (for an executable+work) run the object code and to modify the work, including scripts to+control those activities.  However, it does not include the work's+System Libraries, or general-purpose tools or generally available free+programs which are used unmodified in performing those activities but+which are not part of the work.  For example, Corresponding Source+includes interface definition files associated with source files for+the work, and the source code for shared libraries and dynamically+linked subprograms that the work is specifically designed to require,+such as by intimate data communication or control flow between those+subprograms and other parts of the work.++  The Corresponding Source need not include anything that users+can regenerate automatically from other parts of the Corresponding+Source.++  The Corresponding Source for a work in source code form is that+same work.++  2. Basic Permissions.++  All rights granted under this License are granted for the term of+copyright on the Program, and are irrevocable provided the stated+conditions are met.  This License explicitly affirms your unlimited+permission to run the unmodified Program.  The output from running a+covered work is covered by this License only if the output, given its+content, constitutes a covered work.  This License acknowledges your+rights of fair use or other equivalent, as provided by copyright law.++  You may make, run and propagate covered works that you do not+convey, without conditions so long as your license otherwise remains+in force.  You may convey covered works to others for the sole purpose+of having them make modifications exclusively for you, or provide you+with facilities for running those works, provided that you comply with+the terms of this License in conveying all material for which you do+not control copyright.  Those thus making or running the covered works+for you must do so exclusively on your behalf, under your direction+and control, on terms that prohibit them from making any copies of+your copyrighted material outside their relationship with you.++  Conveying under any other circumstances is permitted solely under+the conditions stated below.  Sublicensing is not allowed; section 10+makes it unnecessary.++  3. Protecting Users' Legal Rights From Anti-Circumvention Law.++  No covered work shall be deemed part of an effective technological+measure under any applicable law fulfilling obligations under article+11 of the WIPO copyright treaty adopted on 20 December 1996, or+similar laws prohibiting or restricting circumvention of such+measures.++  When you convey a covered work, you waive any legal power to forbid+circumvention of technological measures to the extent such circumvention+is effected by exercising rights under this License with respect to+the covered work, and you disclaim any intention to limit operation or+modification of the work as a means of enforcing, against the work's+users, your or third parties' legal rights to forbid circumvention of+technological measures.++  4. Conveying Verbatim Copies.++  You may convey verbatim copies of the Program's source code as you+receive it, in any medium, provided that you conspicuously and+appropriately publish on each copy an appropriate copyright notice;+keep intact all notices stating that this License and any+non-permissive terms added in accord with section 7 apply to the code;+keep intact all notices of the absence of any warranty; and give all+recipients a copy of this License along with the Program.++  You may charge any price or no price for each copy that you convey,+and you may offer support or warranty protection for a fee.++  5. Conveying Modified Source Versions.++  You may convey a work based on the Program, or the modifications to+produce it from the Program, in the form of source code under the+terms of section 4, provided that you also meet all of these conditions:++    a) The work must carry prominent notices stating that you modified+    it, and giving a relevant date.++    b) The work must carry prominent notices stating that it is+    released under this License and any conditions added under section+    7.  This requirement modifies the requirement in section 4 to+    "keep intact all notices".++    c) You must license the entire work, as a whole, under this+    License to anyone who comes into possession of a copy.  This+    License will therefore apply, along with any applicable section 7+    additional terms, to the whole of the work, and all its parts,+    regardless of how they are packaged.  This License gives no+    permission to license the work in any other way, but it does not+    invalidate such permission if you have separately received it.++    d) If the work has interactive user interfaces, each must display+    Appropriate Legal Notices; however, if the Program has interactive+    interfaces that do not display Appropriate Legal Notices, your+    work need not make them do so.++  A compilation of a covered work with other separate and independent+works, which are not by their nature extensions of the covered work,+and which are not combined with it such as to form a larger program,+in or on a volume of a storage or distribution medium, is called an+"aggregate" if the compilation and its resulting copyright are not+used to limit the access or legal rights of the compilation's users+beyond what the individual works permit.  Inclusion of a covered work+in an aggregate does not cause this License to apply to the other+parts of the aggregate.++  6. Conveying Non-Source Forms.++  You may convey a covered work in object code form under the terms+of sections 4 and 5, provided that you also convey the+machine-readable Corresponding Source under the terms of this License,+in one of these ways:++    a) Convey the object code in, or embodied in, a physical product+    (including a physical distribution medium), accompanied by the+    Corresponding Source fixed on a durable physical medium+    customarily used for software interchange.++    b) Convey the object code in, or embodied in, a physical product+    (including a physical distribution medium), accompanied by a+    written offer, valid for at least three years and valid for as+    long as you offer spare parts or customer support for that product+    model, to give anyone who possesses the object code either (1) a+    copy of the Corresponding Source for all the software in the+    product that is covered by this License, on a durable physical+    medium customarily used for software interchange, for a price no+    more than your reasonable cost of physically performing this+    conveying of source, or (2) access to copy the+    Corresponding Source from a network server at no charge.++    c) Convey individual copies of the object code with a copy of the+    written offer to provide the Corresponding Source.  This+    alternative is allowed only occasionally and noncommercially, and+    only if you received the object code with such an offer, in accord+    with subsection 6b.++    d) Convey the object code by offering access from a designated+    place (gratis or for a charge), and offer equivalent access to the+    Corresponding Source in the same way through the same place at no+    further charge.  You need not require recipients to copy the+    Corresponding Source along with the object code.  If the place to+    copy the object code is a network server, the Corresponding Source+    may be on a different server (operated by you or a third party)+    that supports equivalent copying facilities, provided you maintain+    clear directions next to the object code saying where to find the+    Corresponding Source.  Regardless of what server hosts the+    Corresponding Source, you remain obligated to ensure that it is+    available for as long as needed to satisfy these requirements.++    e) Convey the object code using peer-to-peer transmission, provided+    you inform other peers where the object code and Corresponding+    Source of the work are being offered to the general public at no+    charge under subsection 6d.++  A separable portion of the object code, whose source code is excluded+from the Corresponding Source as a System Library, need not be+included in conveying the object code work.++  A "User Product" is either (1) a "consumer product", which means any+tangible personal property which is normally used for personal, family,+or household purposes, or (2) anything designed or sold for incorporation+into a dwelling.  In determining whether a product is a consumer product,+doubtful cases shall be resolved in favor of coverage.  For a particular+product received by a particular user, "normally used" refers to a+typical or common use of that class of product, regardless of the status+of the particular user or of the way in which the particular user+actually uses, or expects or is expected to use, the product.  A product+is a consumer product regardless of whether the product has substantial+commercial, industrial or non-consumer uses, unless such uses represent+the only significant mode of use of the product.++  "Installation Information" for a User Product means any methods,+procedures, authorization keys, or other information required to install+and execute modified versions of a covered work in that User Product from+a modified version of its Corresponding Source.  The information must+suffice to ensure that the continued functioning of the modified object+code is in no case prevented or interfered with solely because+modification has been made.++  If you convey an object code work under this section in, or with, or+specifically for use in, a User Product, and the conveying occurs as+part of a transaction in which the right of possession and use of the+User Product is transferred to the recipient in perpetuity or for a+fixed term (regardless of how the transaction is characterized), the+Corresponding Source conveyed under this section must be accompanied+by the Installation Information.  But this requirement does not apply+if neither you nor any third party retains the ability to install+modified object code on the User Product (for example, the work has+been installed in ROM).++  The requirement to provide Installation Information does not include a+requirement to continue to provide support service, warranty, or updates+for a work that has been modified or installed by the recipient, or for+the User Product in which it has been modified or installed.  Access to a+network may be denied when the modification itself materially and+adversely affects the operation of the network or violates the rules and+protocols for communication across the network.++  Corresponding Source conveyed, and Installation Information provided,+in accord with this section must be in a format that is publicly+documented (and with an implementation available to the public in+source code form), and must require no special password or key for+unpacking, reading or copying.++  7. Additional Terms.++  "Additional permissions" are terms that supplement the terms of this+License by making exceptions from one or more of its conditions.+Additional permissions that are applicable to the entire Program shall+be treated as though they were included in this License, to the extent+that they are valid under applicable law.  If additional permissions+apply only to part of the Program, that part may be used separately+under those permissions, but the entire Program remains governed by+this License without regard to the additional permissions.++  When you convey a copy of a covered work, you may at your option+remove any additional permissions from that copy, or from any part of+it.  (Additional permissions may be written to require their own+removal in certain cases when you modify the work.)  You may place+additional permissions on material, added by you to a covered work,+for which you have or can give appropriate copyright permission.++  Notwithstanding any other provision of this License, for material you+add to a covered work, you may (if authorized by the copyright holders of+that material) supplement the terms of this License with terms:++    a) Disclaiming warranty or limiting liability differently from the+    terms of sections 15 and 16 of this License; or++    b) Requiring preservation of specified reasonable legal notices or+    author attributions in that material or in the Appropriate Legal+    Notices displayed by works containing it; or++    c) Prohibiting misrepresentation of the origin of that material, or+    requiring that modified versions of such material be marked in+    reasonable ways as different from the original version; or++    d) Limiting the use for publicity purposes of names of licensors or+    authors of the material; or++    e) Declining to grant rights under trademark law for use of some+    trade names, trademarks, or service marks; or++    f) Requiring indemnification of licensors and authors of that+    material by anyone who conveys the material (or modified versions of+    it) with contractual assumptions of liability to the recipient, for+    any liability that these contractual assumptions directly impose on+    those licensors and authors.++  All other non-permissive additional terms are considered "further+restrictions" within the meaning of section 10.  If the Program as you+received it, or any part of it, contains a notice stating that it is+governed by this License along with a term that is a further+restriction, you may remove that term.  If a license document contains+a further restriction but permits relicensing or conveying under this+License, you may add to a covered work material governed by the terms+of that license document, provided that the further restriction does+not survive such relicensing or conveying.++  If you add terms to a covered work in accord with this section, you+must place, in the relevant source files, a statement of the+additional terms that apply to those files, or a notice indicating+where to find the applicable terms.++  Additional terms, permissive or non-permissive, may be stated in the+form of a separately written license, or stated as exceptions;+the above requirements apply either way.++  8. Termination.++  You may not propagate or modify a covered work except as expressly+provided under this License.  Any attempt otherwise to propagate or+modify it is void, and will automatically terminate your rights under+this License (including any patent licenses granted under the third+paragraph of section 11).++  However, if you cease all violation of this License, then your+license from a particular copyright holder is reinstated (a)+provisionally, unless and until the copyright holder explicitly and+finally terminates your license, and (b) permanently, if the copyright+holder fails to notify you of the violation by some reasonable means+prior to 60 days after the cessation.++  Moreover, your license from a particular copyright holder is+reinstated permanently if the copyright holder notifies you of the+violation by some reasonable means, this is the first time you have+received notice of violation of this License (for any work) from that+copyright holder, and you cure the violation prior to 30 days after+your receipt of the notice.++  Termination of your rights under this section does not terminate the+licenses of parties who have received copies or rights from you under+this License.  If your rights have been terminated and not permanently+reinstated, you do not qualify to receive new licenses for the same+material under section 10.++  9. Acceptance Not Required for Having Copies.++  You are not required to accept this License in order to receive or+run a copy of the Program.  Ancillary propagation of a covered work+occurring solely as a consequence of using peer-to-peer transmission+to receive a copy likewise does not require acceptance.  However,+nothing other than this License grants you permission to propagate or+modify any covered work.  These actions infringe copyright if you do+not accept this License.  Therefore, by modifying or propagating a+covered work, you indicate your acceptance of this License to do so.++  10. Automatic Licensing of Downstream Recipients.++  Each time you convey a covered work, the recipient automatically+receives a license from the original licensors, to run, modify and+propagate that work, subject to this License.  You are not responsible+for enforcing compliance by third parties with this License.++  An "entity transaction" is a transaction transferring control of an+organization, or substantially all assets of one, or subdividing an+organization, or merging organizations.  If propagation of a covered+work results from an entity transaction, each party to that+transaction who receives a copy of the work also receives whatever+licenses to the work the party's predecessor in interest had or could+give under the previous paragraph, plus a right to possession of the+Corresponding Source of the work from the predecessor in interest, if+the predecessor has it or can get it with reasonable efforts.++  You may not impose any further restrictions on the exercise of the+rights granted or affirmed under this License.  For example, you may+not impose a license fee, royalty, or other charge for exercise of+rights granted under this License, and you may not initiate litigation+(including a cross-claim or counterclaim in a lawsuit) alleging that+any patent claim is infringed by making, using, selling, offering for+sale, or importing the Program or any portion of it.++  11. Patents.++  A "contributor" is a copyright holder who authorizes use under this+License of the Program or a work on which the Program is based.  The+work thus licensed is called the contributor's "contributor version".++  A contributor's "essential patent claims" are all patent claims+owned or controlled by the contributor, whether already acquired or+hereafter acquired, that would be infringed by some manner, permitted+by this License, of making, using, or selling its contributor version,+but do not include claims that would be infringed only as a+consequence of further modification of the contributor version.  For+purposes of this definition, "control" includes the right to grant+patent sublicenses in a manner consistent with the requirements of+this License.++  Each contributor grants you a non-exclusive, worldwide, royalty-free+patent license under the contributor's essential patent claims, to+make, use, sell, offer for sale, import and otherwise run, modify and+propagate the contents of its contributor version.++  In the following three paragraphs, a "patent license" is any express+agreement or commitment, however denominated, not to enforce a patent+(such as an express permission to practice a patent or covenant not to+sue for patent infringement).  To "grant" such a patent license to a+party means to make such an agreement or commitment not to enforce a+patent against the party.++  If you convey a covered work, knowingly relying on a patent license,+and the Corresponding Source of the work is not available for anyone+to copy, free of charge and under the terms of this License, through a+publicly available network server or other readily accessible means,+then you must either (1) cause the Corresponding Source to be so+available, or (2) arrange to deprive yourself of the benefit of the+patent license for this particular work, or (3) arrange, in a manner+consistent with the requirements of this License, to extend the patent+license to downstream recipients.  "Knowingly relying" means you have+actual knowledge that, but for the patent license, your conveying the+covered work in a country, or your recipient's use of the covered work+in a country, would infringe one or more identifiable patents in that+country that you have reason to believe are valid.++  If, pursuant to or in connection with a single transaction or+arrangement, you convey, or propagate by procuring conveyance of, a+covered work, and grant a patent license to some of the parties+receiving the covered work authorizing them to use, propagate, modify+or convey a specific copy of the covered work, then the patent license+you grant is automatically extended to all recipients of the covered+work and works based on it.++  A patent license is "discriminatory" if it does not include within+the scope of its coverage, prohibits the exercise of, or is+conditioned on the non-exercise of one or more of the rights that are+specifically granted under this License.  You may not convey a covered+work if you are a party to an arrangement with a third party that is+in the business of distributing software, under which you make payment+to the third party based on the extent of your activity of conveying+the work, and under which the third party grants, to any of the+parties who would receive the covered work from you, a discriminatory+patent license (a) in connection with copies of the covered work+conveyed by you (or copies made from those copies), or (b) primarily+for and in connection with specific products or compilations that+contain the covered work, unless you entered into that arrangement,+or that patent license was granted, prior to 28 March 2007.++  Nothing in this License shall be construed as excluding or limiting+any implied license or other defenses to infringement that may+otherwise be available to you under applicable patent law.++  12. No Surrender of Others' Freedom.++  If conditions are imposed on you (whether by court order, agreement or+otherwise) that contradict the conditions of this License, they do not+excuse you from the conditions of this License.  If you cannot convey a+covered work so as to satisfy simultaneously your obligations under this+License and any other pertinent obligations, then as a consequence you may+not convey it at all.  For example, if you agree to terms that obligate you+to collect a royalty for further conveying from those to whom you convey+the Program, the only way you could satisfy both those terms and this+License would be to refrain entirely from conveying the Program.++  13. Use with the GNU Affero General Public License.++  Notwithstanding any other provision of this License, you have+permission to link or combine any covered work with a work licensed+under version 3 of the GNU Affero General Public License into a single+combined work, and to convey the resulting work.  The terms of this+License will continue to apply to the part which is the covered work,+but the special requirements of the GNU Affero General Public License,+section 13, concerning interaction through a network will apply to the+combination as such.++  14. Revised Versions of this License.++  The Free Software Foundation may publish revised and/or new versions of+the GNU General Public License from time to time.  Such new versions will+be similar in spirit to the present version, but may differ in detail to+address new problems or concerns.++  Each version is given a distinguishing version number.  If the+Program specifies that a certain numbered version of the GNU General+Public License "or any later version" applies to it, you have the+option of following the terms and conditions either of that numbered+version or of any later version published by the Free Software+Foundation.  If the Program does not specify a version number of the+GNU General Public License, you may choose any version ever published+by the Free Software Foundation.++  If the Program specifies that a proxy can decide which future+versions of the GNU General Public License can be used, that proxy's+public statement of acceptance of a version permanently authorizes you+to choose that version for the Program.++  Later license versions may give you additional or different+permissions.  However, no additional obligations are imposed on any+author or copyright holder as a result of your choosing to follow a+later version.++  15. Disclaimer of Warranty.++  THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY+APPLICABLE LAW.  EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT+HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY+OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,+THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR+PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM+IS WITH YOU.  SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF+ALL NECESSARY SERVICING, REPAIR OR CORRECTION.++  16. Limitation of Liability.++  IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS+THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY+GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE+USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF+DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD+PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),+EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF+SUCH DAMAGES.++  17. Interpretation of Sections 15 and 16.++  If the disclaimer of warranty and limitation of liability provided+above cannot be given local legal effect according to their terms,+reviewing courts shall apply local law that most closely approximates+an absolute waiver of all civil liability in connection with the+Program, unless a warranty or assumption of liability accompanies a+copy of the Program in return for a fee.++                     END OF TERMS AND CONDITIONS++            How to Apply These Terms to Your New Programs++  If you develop a new program, and you want it to be of the greatest+possible use to the public, the best way to achieve this is to make it+free software which everyone can redistribute and change under these terms.++  To do so, attach the following notices to the program.  It is safest+to attach them to the start of each source file to most effectively+state the exclusion of warranty; and each file should have at least+the "copyright" line and a pointer to where the full notice is found.++    <one line to give the program's name and a brief idea of what it does.>+    Copyright (C) <year>  <name of author>++    This program is free software: you can redistribute it and/or modify+    it under the terms of the GNU General Public License as published by+    the Free Software Foundation, either version 3 of the License, or+    (at your option) any later version.++    This program is distributed in the hope that it will be useful,+    but WITHOUT ANY WARRANTY; without even the implied warranty of+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+    GNU General Public License for more details.++    You should have received a copy of the GNU General Public License+    along with this program.  If not, see <http://www.gnu.org/licenses/>.++Also add information on how to contact you by electronic and paper mail.++  If the program does terminal interaction, make it output a short+notice like this when it starts in an interactive mode:++    <program>  Copyright (C) <year>  <name of author>+    This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.+    This is free software, and you are welcome to redistribute it+    under certain conditions; type `show c' for details.++The hypothetical commands `show w' and `show c' should show the appropriate+parts of the General Public License.  Of course, your program's commands+might be different; for a GUI interface, you would use an "about box".++  You should also get your employer (if you work as a programmer) or school,+if any, to sign a "copyright disclaimer" for the program, if necessary.+For more information on this, and how to apply and follow the GNU GPL, see+<http://www.gnu.org/licenses/>.++  The GNU General Public License does not permit incorporating your program+into proprietary programs.  If your program is a subroutine library, you+may consider it more useful to permit linking proprietary applications with+the library.  If this is what you want to do, use the GNU Lesser General+Public License instead of this License.  But first, please read+<http://www.gnu.org/philosophy/why-not-lgpl.html>.
+ doc/legal/license-OculusSDK.txt view
@@ -0,0 +1,61 @@+SDK Software License+Oculus VR, Inc. Software Development Kit License Agreement++Copyright © 2013 Oculus VR, Inc. All rights reserved.+Human-Readable Summary*+You are Free to:++Use, modify, and distribute the Oculus VR SDK in source and binary form with your software.+With the Following Restrictions:++    You can only distribute or re-distribute LibOVR in whole, not in part.+    Modifications to the Oculus VR SDK in source or binary form must be shared with Oculus VR.+    If your applications cause health and safety issues, you may lose your right to use the Oculus VR SDK, including LibOVR.++* - This human-readable Summary is not a license. It is simply a convenient reference for understanding the full Oculus VR SDK License Agreement. The Summary is written as a user-friendly interface to the full Oculus VR SDK License below. This Summary itself has no legal value, and its contents do not appear in the actual license.+Full-length Legal Copy:++1. Subject to the terms and conditions of this License Agreement (the "License"), Oculus VR, Inc. ("Oculus VR") hereby grants to you a perpetual, worldwide, non-exclusive, no-charge, royalty-free, sublicenseable copyright license to use, reproduce, redistribute (subject to restrictions below), modify, and improve the software contained in this Software Development Kit ("SDK"), including, but not limited to, the samples, headers, LibOVR headers, and LibOVR source. This license includes the right to prepare derivative works ("Derivative Works"), whether in source, binary, or object form, based on the SDK, in whole or in part, including third party software unless otherwise noted. Derivative Works are defined as source, binary or object code derived exclusively from the SDK; provided, however, that Derivative Works do not include engines, utilities, applications, content or games which may be developed using the SDK. By way of example a videogame that is developed using the SDK would not be a Derivative Work and a utility or tool set in a pre-existing game engine that is adapted to work with the SDK would not be a Derivative Work. By way of example, but not limitation, a Derivative Work is or would be: either (i) an adaptation of a utility or piece of code from the SDK to improve efficiency; or (ii) an addition of code or improvement to the SDK that adds functionality. When you use the SDK (including Derivative Works) with your engines, utilities, applications, content, or games (collectively and generally referred to as “Developer Content”), you retain all rights to your Developer Content, and you have no obligations to share or license Developer Content to Oculus VR or any third parties.++2. You, the recipient and user of the SDK, hereby agree and accept that that Oculus VR shall own all right, title and interest to the intellectual property rights, including, but limited to copyright, trademark and patent rights, to any Derivative Works that you or your licensees may create, and you hereby assign any and all such rights to such Derivative Works to Oculus VR. We hereby grant to you the right to use these Derivative Works solely in conjunction with the SDK on a fully paid up, no-charge, royalty-free, world-wide, in perpetuity, non-exclusive basis. Furthermore, for the sake of clarification, Oculus VR and its assignees and licensees shall be free to use such Derivative Works without any approval from you and without compensation or attribution to you. You also agree upon Oculus VR's request to provide the source and binary code of any Derivative Works to Oculus VR. FAILURE TO COMPLY WITH THIS REQUEST IS THE BASIS FOR AUTOMATIC TERMINATION OF THIS LICENSE BY OCULUS VR.++3. Subject to the terms and conditions of this License, your license to redistribute and sublicense the SDK and Derivative Works is also expressly made subject to the following conditions:++3.1. You may sublicense and redistribute the source, binary, or object code of the SDK in whole or in part; provided, however, you may only license, sublicense or redistribute the source, binary or object code of LibOVR in whole, and you may not license, sublicense or redistribute any portion or element of LibOVR separately or in part (in either source, binary or object form). You may only license, sublicense or redistribute Derivative Works solely with and in conjunction with either the SDK or LibOVR. The SDK (including, but not limited to LibOVR), may not be used, licensed, or sublicensed to interface with commercial headsets not authorized and approved by Oculus VR;++3.2. You must include with all such redistributed or sublicensed SDK code the following copyright notice: "Copyright © 2013 Oculus VR, Inc. All rights reserved," and include the list of conditions contained in this Section 3, including the full text of the disclaimer in Section 3.6 below;++3.3. Neither the name of Oculus VR, Inc. nor the names of Oculus VR, Inc.'s contributors, licensors, employees, or contractors, may be used to endorse or promote products derived from this SDK without specific prior written permission of Oculus VR, Inc.;++3.4. You must give any other recipients of the SDK or any elements thereof, including LibOVR or Derivative Works, a copy of this License and you must cause any modified files to carry prominent notices stating that you changed the files;++3.5. If the SDK or a specific element thereof such as LibOVR includes a "LICENSE" text file as part of its distribution (the “License Notice”), then any Derivative Works that you distribute with the SDK in whole or in part must include a readable copy of such attribution notices as are contained within the applicable License Notice file (excluding those notices that do not pertain to any part of the Derivative Works), in at least one of the following places: within a License Notice text file distributed as part of the Derivative Works; within the source form or documentation, if provided along with the Derivative Works; or, within a display generated by the Derivative Works, if and wherever such third-party notices normally appear. You must also include in the License Notice file for all Derivative Works a copy of all notices (including any product liability or health and safety notices). The contents of the License Notice file are for informational purposes only and do not modify the License. You may add your own attribution notices within Derivative Works that you distribute, alongside or as an addendum to the License Notice text from the SDK or any part thereof, provided that such additional attribution notices cannot be construed as modifying the License.++3.6. THIS SDK AND ANY COMPONENT THEREOF IS PROVIDED BY OCULUS VR AND ITS CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL OCULUS VR AS THE COPYRIGHT OWNER OR ITS CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SDK OR THE DERIVATIVE WORKS, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.++4. This License does not grant permission to use the trade names, trademarks, service marks, or product names of Oculus VR, except as required for reasonable and customary use in describing the origin of the SDK, LibOVR, or any element thereof, and reproducing the content of the License Notice file.++5. In no event and under no legal theory, whether in tort (including negligence), contract, or otherwise, unless required by applicable law (such as deliberate and grossly negligent acts) or agreed to in writing, shall Oculus VR or any contributor be liable to you or your licensees or sublicensees for damages, including any direct, indirect, special, incidental, or consequential damages of any character arising as a result of this License or out of the use or inability to use the SDK, LibOVR, any element thereof or any Derivative Works (including but not limited to damages for loss of goodwill, work stoppage, computer failure or malfunction, or any and all other commercial damages or losses), even if you or such contributor has been advised of the possibility of such damages.++6. Your acceptance of the terms and conditions of this License in and of itself and for all Developer Content created as of December 1, 2013, may be evidenced by any of the following: your usage of the SDK or any element thereof, acceptance of the click-through agreement, or opening the packaging of the CD-ROM containing the SDK or any element thereof, including LibOVR. As this License is updated for future releases of the SDK and/or LibOVR, you agree to abide by and meet all requirements of future updates of this License for those future SDK releases as evidenced by the same usage of the SDK or any element thereof and the future updates of this License will apply for that future Developer Content that may developed for or with that future SDK or any element thereof. Your prior Developer Content developed with a prior SDK version will be governed by the applicable prior version of the License and you shall have the right to continue to develop and exploit Developer Content (prior and future) with the prior version of the SDK and the applicable prior version of the License.++7. Oculus VR reserves the right to terminate this License and all your rights hereunder in the event you materially breach this License and fail to cure such breach within ten (10) business days after notice of breach from Oculus. Furthermore, Oculus VR also reserves the right to cancel or terminate this License for any of the following reasons upon notice to you, subject to the appeal process set forth in Section 13:++    Intellectual property infringement by you with Developer Content that is used with or by the SDK or any part thereof or any of the Derivative Works;+    Developer Content that violates applicable law;+    Health and safety issues associated with your Developer Content;+    Failure to provide required notices or deliver source code and/or binary of Derivative Works as set forth above.++If you believe that you have been unfairly terminated under this Section 7 with respect to material breach or with respect to these above conditions, you have the right to appeal the termination of this License under Section 13.++8. This License may be amended by Oculus VR on a prospective basis, and your usage of the License after such amendments or changes signifies your consent to and acceptance of any such amendments or changes on a going forward basis.++9. In the event any provision of this License is determined to be invalid, prohibited or unenforceable by a court or other body of competent jurisdiction, this License shall be construed as if such invalid, prohibited or unenforceable provision has been more narrowly drawn so as not to be invalid, prohibited or unenforceable.++10. You may not assign any rights or obligations under this License without the advance written consent of Oculus VR, which may be withheld in its sole discretion. Oculus VR may assign its rights or obligations under this License in its sole discretion.++11. Failure of either party at any time to enforce any of the provisions of this License will not be construed as a waiver of such provisions or in any way affect the validity of this License or parts thereof.++12. Your remedies under this License shall be limited to the right to collect money damages, if any, and you hereby waive your right to injunctive or other equitable relief.++13. This License shall be governed by the laws of the State of California, without giving effect to choice of law principles. All disputes relating to this License shall be resolved by binding non-appearance-based arbitration before a neutral arbitrator in Orange County, California. If your License has been terminated hereunder by Oculus, you may appeal your termination through this arbitration process on an expedited basis with an arbitration within thirty days of your giving Oculus VR notice of the appeal. The arbitration shall be conducted in accordance with the rules and procedures of JAMS then in effect, and the judgment of the arbitrator shall be final and capable of entry in any court of competent jurisdiction. You agree to submit to the personal jurisdiction of the courts located within Orange County, California in connection with any entrance of an arbitrator’s judgment or decision or any dispute with respect to the arbitration process or procedure or Oculus VR’s exercise of its equitable rights or remedies.
+ doc/legal/license-PhysicsFS.txt view
@@ -0,0 +1,44 @@++   Copyright (c) 2001-2012 Ryan C. Gordon and others.++   This software is provided 'as-is', without any express or implied warranty.+   In no event will the authors be held liable for any damages arising from+   the use of this software.++   Permission is granted to anyone to use this software for any purpose,+   including commercial applications, and to alter it and redistribute it+   freely, subject to the following restrictions:++   1. The origin of this software must not be misrepresented; you must not+   claim that you wrote the original software. If you use this software in a+   product, an acknowledgment in the product documentation would be+   appreciated but is not required.++   2. Altered source versions must be plainly marked as such, and must not be+   misrepresented as being the original software.++   3. This notice may not be removed or altered from any source distribution.++       Ryan C. Gordon <icculus@icculus.org>+++++Notes, separate from the license. This is not legal advice.++Versions of PhysicsFS prior to 0.1.9 are licensed under the GNU Lesser General+ Public License, which restricts you significantly more. For your own safety,+ please make sure you've got 0.1.9 or later if you plan to use physfs in a+ commercial or closed-source project.++Optional pieces of PhysicsFS may fall under other licenses, please consult+your lawyer for legal advice, which this is not...++   zlib: if you enable ZIP archive support, PhysicsFS uses zlib. Its license+         requirements are identical to PhysicsFS.+         Please see zlib123/README for details.++   lzma: if you enable LZMA (7zip) support, PhysicsFS uses the lzma sdk.+         It uses the LGPL license, with exceptions for closed-source programs.+         Please see lzma/lzma.txt for details.+
+ doc/legal/license-SDL2.txt view
@@ -0,0 +1,20 @@++Simple DirectMedia Layer+Copyright (C) 1997-2014 Sam Lantinga <slouken@libsdl.org>+  +This software is provided 'as-is', without any express or implied+warranty.  In no event will the authors be held liable for any damages+arising from the use of this software.++Permission is granted to anyone to use this software for any purpose,+including commercial applications, and to alter it and redistribute it+freely, subject to the following restrictions:+  +1. The origin of this software must not be misrepresented; you must not+   claim that you wrote the original software. If you use this software+   in a product, an acknowledgment in the product documentation would be+   appreciated but is not required. +2. Altered source versions must be plainly marked as such, and must not be+   misrepresented as being the original software.+3. This notice may not be removed or altered from any source distribution.+
+ doc/legal/license-SDL2_net.txt view
@@ -0,0 +1,20 @@+/*+  SDL_net:  An example cross-platform network library for use with SDL+  Copyright (C) 1997-2013 Sam Lantinga <slouken@libsdl.org>++  This software is provided 'as-is', without any express or implied+  warranty.  In no event will the authors be held liable for any damages+  arising from the use of this software.++  Permission is granted to anyone to use this software for any purpose,+  including commercial applications, and to alter it and redistribute it+  freely, subject to the following restrictions:++  1. The origin of this software must not be misrepresented; you must not+     claim that you wrote the original software. If you use this software+     in a product, an acknowledgment in the product documentation would be+     appreciated but is not required.+  2. Altered source versions must be plainly marked as such, and must not be+     misrepresented as being the original software.+  3. This notice may not be removed or altered from any source distribution.+*/
+ doc/legal/license-SDL2_ttf.txt view
@@ -0,0 +1,20 @@+/*+  SDL_ttf:  A companion library to SDL for working with TrueType (tm) fonts+  Copyright (C) 1997-2013 Sam Lantinga <slouken@libsdl.org>++  This software is provided 'as-is', without any express or implied+  warranty.  In no event will the authors be held liable for any damages+  arising from the use of this software.++  Permission is granted to anyone to use this software for any purpose,+  including commercial applications, and to alter it and redistribute it+  freely, subject to the following restrictions:++  1. The origin of this software must not be misrepresented; you must not+     claim that you wrote the original software. If you use this software+     in a product, an acknowledgment in the product documentation would be+     appreciated but is not required.+  2. Altered source versions must be plainly marked as such, and must not be+     misrepresented as being the original software.+  3. This notice may not be removed or altered from any source distribution.+*/
+ doc/legal/license-gettext.txt view
@@ -0,0 +1,674 @@+                    GNU GENERAL PUBLIC LICENSE+                       Version 3, 29 June 2007++ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.++                            Preamble++  The GNU General Public License is a free, copyleft license for+software and other kinds of works.++  The licenses for most software and other practical works are designed+to take away your freedom to share and change the works.  By contrast,+the GNU General Public License is intended to guarantee your freedom to+share and change all versions of a program--to make sure it remains free+software for all its users.  We, the Free Software Foundation, use the+GNU General Public License for most of our software; it applies also to+any other work released this way by its authors.  You can apply it to+your programs, too.++  When we speak of free software, we are referring to freedom, not+price.  Our General Public Licenses are designed to make sure that you+have the freedom to distribute copies of free software (and charge for+them if you wish), that you receive source code or can get it if you+want it, that you can change the software or use pieces of it in new+free programs, and that you know you can do these things.++  To protect your rights, we need to prevent others from denying you+these rights or asking you to surrender the rights.  Therefore, you have+certain responsibilities if you distribute copies of the software, or if+you modify it: responsibilities to respect the freedom of others.++  For example, if you distribute copies of such a program, whether+gratis or for a fee, you must pass on to the recipients the same+freedoms that you received.  You must make sure that they, too, receive+or can get the source code.  And you must show them these terms so they+know their rights.++  Developers that use the GNU GPL protect your rights with two steps:+(1) assert copyright on the software, and (2) offer you this License+giving you legal permission to copy, distribute and/or modify it.++  For the developers' and authors' protection, the GPL clearly explains+that there is no warranty for this free software.  For both users' and+authors' sake, the GPL requires that modified versions be marked as+changed, so that their problems will not be attributed erroneously to+authors of previous versions.++  Some devices are designed to deny users access to install or run+modified versions of the software inside them, although the manufacturer+can do so.  This is fundamentally incompatible with the aim of+protecting users' freedom to change the software.  The systematic+pattern of such abuse occurs in the area of products for individuals to+use, which is precisely where it is most unacceptable.  Therefore, we+have designed this version of the GPL to prohibit the practice for those+products.  If such problems arise substantially in other domains, we+stand ready to extend this provision to those domains in future versions+of the GPL, as needed to protect the freedom of users.++  Finally, every program is threatened constantly by software patents.+States should not allow patents to restrict development and use of+software on general-purpose computers, but in those that do, we wish to+avoid the special danger that patents applied to a free program could+make it effectively proprietary.  To prevent this, the GPL assures that+patents cannot be used to render the program non-free.++  The precise terms and conditions for copying, distribution and+modification follow.++                       TERMS AND CONDITIONS++  0. Definitions.++  "This License" refers to version 3 of the GNU General Public License.++  "Copyright" also means copyright-like laws that apply to other kinds of+works, such as semiconductor masks.++  "The Program" refers to any copyrightable work licensed under this+License.  Each licensee is addressed as "you".  "Licensees" and+"recipients" may be individuals or organizations.++  To "modify" a work means to copy from or adapt all or part of the work+in a fashion requiring copyright permission, other than the making of an+exact copy.  The resulting work is called a "modified version" of the+earlier work or a work "based on" the earlier work.++  A "covered work" means either the unmodified Program or a work based+on the Program.++  To "propagate" a work means to do anything with it that, without+permission, would make you directly or secondarily liable for+infringement under applicable copyright law, except executing it on a+computer or modifying a private copy.  Propagation includes copying,+distribution (with or without modification), making available to the+public, and in some countries other activities as well.++  To "convey" a work means any kind of propagation that enables other+parties to make or receive copies.  Mere interaction with a user through+a computer network, with no transfer of a copy, is not conveying.++  An interactive user interface displays "Appropriate Legal Notices"+to the extent that it includes a convenient and prominently visible+feature that (1) displays an appropriate copyright notice, and (2)+tells the user that there is no warranty for the work (except to the+extent that warranties are provided), that licensees may convey the+work under this License, and how to view a copy of this License.  If+the interface presents a list of user commands or options, such as a+menu, a prominent item in the list meets this criterion.++  1. Source Code.++  The "source code" for a work means the preferred form of the work+for making modifications to it.  "Object code" means any non-source+form of a work.++  A "Standard Interface" means an interface that either is an official+standard defined by a recognized standards body, or, in the case of+interfaces specified for a particular programming language, one that+is widely used among developers working in that language.++  The "System Libraries" of an executable work include anything, other+than the work as a whole, that (a) is included in the normal form of+packaging a Major Component, but which is not part of that Major+Component, and (b) serves only to enable use of the work with that+Major Component, or to implement a Standard Interface for which an+implementation is available to the public in source code form.  A+"Major Component", in this context, means a major essential component+(kernel, window system, and so on) of the specific operating system+(if any) on which the executable work runs, or a compiler used to+produce the work, or an object code interpreter used to run it.++  The "Corresponding Source" for a work in object code form means all+the source code needed to generate, install, and (for an executable+work) run the object code and to modify the work, including scripts to+control those activities.  However, it does not include the work's+System Libraries, or general-purpose tools or generally available free+programs which are used unmodified in performing those activities but+which are not part of the work.  For example, Corresponding Source+includes interface definition files associated with source files for+the work, and the source code for shared libraries and dynamically+linked subprograms that the work is specifically designed to require,+such as by intimate data communication or control flow between those+subprograms and other parts of the work.++  The Corresponding Source need not include anything that users+can regenerate automatically from other parts of the Corresponding+Source.++  The Corresponding Source for a work in source code form is that+same work.++  2. Basic Permissions.++  All rights granted under this License are granted for the term of+copyright on the Program, and are irrevocable provided the stated+conditions are met.  This License explicitly affirms your unlimited+permission to run the unmodified Program.  The output from running a+covered work is covered by this License only if the output, given its+content, constitutes a covered work.  This License acknowledges your+rights of fair use or other equivalent, as provided by copyright law.++  You may make, run and propagate covered works that you do not+convey, without conditions so long as your license otherwise remains+in force.  You may convey covered works to others for the sole purpose+of having them make modifications exclusively for you, or provide you+with facilities for running those works, provided that you comply with+the terms of this License in conveying all material for which you do+not control copyright.  Those thus making or running the covered works+for you must do so exclusively on your behalf, under your direction+and control, on terms that prohibit them from making any copies of+your copyrighted material outside their relationship with you.++  Conveying under any other circumstances is permitted solely under+the conditions stated below.  Sublicensing is not allowed; section 10+makes it unnecessary.++  3. Protecting Users' Legal Rights From Anti-Circumvention Law.++  No covered work shall be deemed part of an effective technological+measure under any applicable law fulfilling obligations under article+11 of the WIPO copyright treaty adopted on 20 December 1996, or+similar laws prohibiting or restricting circumvention of such+measures.++  When you convey a covered work, you waive any legal power to forbid+circumvention of technological measures to the extent such circumvention+is effected by exercising rights under this License with respect to+the covered work, and you disclaim any intention to limit operation or+modification of the work as a means of enforcing, against the work's+users, your or third parties' legal rights to forbid circumvention of+technological measures.++  4. Conveying Verbatim Copies.++  You may convey verbatim copies of the Program's source code as you+receive it, in any medium, provided that you conspicuously and+appropriately publish on each copy an appropriate copyright notice;+keep intact all notices stating that this License and any+non-permissive terms added in accord with section 7 apply to the code;+keep intact all notices of the absence of any warranty; and give all+recipients a copy of this License along with the Program.++  You may charge any price or no price for each copy that you convey,+and you may offer support or warranty protection for a fee.++  5. Conveying Modified Source Versions.++  You may convey a work based on the Program, or the modifications to+produce it from the Program, in the form of source code under the+terms of section 4, provided that you also meet all of these conditions:++    a) The work must carry prominent notices stating that you modified+    it, and giving a relevant date.++    b) The work must carry prominent notices stating that it is+    released under this License and any conditions added under section+    7.  This requirement modifies the requirement in section 4 to+    "keep intact all notices".++    c) You must license the entire work, as a whole, under this+    License to anyone who comes into possession of a copy.  This+    License will therefore apply, along with any applicable section 7+    additional terms, to the whole of the work, and all its parts,+    regardless of how they are packaged.  This License gives no+    permission to license the work in any other way, but it does not+    invalidate such permission if you have separately received it.++    d) If the work has interactive user interfaces, each must display+    Appropriate Legal Notices; however, if the Program has interactive+    interfaces that do not display Appropriate Legal Notices, your+    work need not make them do so.++  A compilation of a covered work with other separate and independent+works, which are not by their nature extensions of the covered work,+and which are not combined with it such as to form a larger program,+in or on a volume of a storage or distribution medium, is called an+"aggregate" if the compilation and its resulting copyright are not+used to limit the access or legal rights of the compilation's users+beyond what the individual works permit.  Inclusion of a covered work+in an aggregate does not cause this License to apply to the other+parts of the aggregate.++  6. Conveying Non-Source Forms.++  You may convey a covered work in object code form under the terms+of sections 4 and 5, provided that you also convey the+machine-readable Corresponding Source under the terms of this License,+in one of these ways:++    a) Convey the object code in, or embodied in, a physical product+    (including a physical distribution medium), accompanied by the+    Corresponding Source fixed on a durable physical medium+    customarily used for software interchange.++    b) Convey the object code in, or embodied in, a physical product+    (including a physical distribution medium), accompanied by a+    written offer, valid for at least three years and valid for as+    long as you offer spare parts or customer support for that product+    model, to give anyone who possesses the object code either (1) a+    copy of the Corresponding Source for all the software in the+    product that is covered by this License, on a durable physical+    medium customarily used for software interchange, for a price no+    more than your reasonable cost of physically performing this+    conveying of source, or (2) access to copy the+    Corresponding Source from a network server at no charge.++    c) Convey individual copies of the object code with a copy of the+    written offer to provide the Corresponding Source.  This+    alternative is allowed only occasionally and noncommercially, and+    only if you received the object code with such an offer, in accord+    with subsection 6b.++    d) Convey the object code by offering access from a designated+    place (gratis or for a charge), and offer equivalent access to the+    Corresponding Source in the same way through the same place at no+    further charge.  You need not require recipients to copy the+    Corresponding Source along with the object code.  If the place to+    copy the object code is a network server, the Corresponding Source+    may be on a different server (operated by you or a third party)+    that supports equivalent copying facilities, provided you maintain+    clear directions next to the object code saying where to find the+    Corresponding Source.  Regardless of what server hosts the+    Corresponding Source, you remain obligated to ensure that it is+    available for as long as needed to satisfy these requirements.++    e) Convey the object code using peer-to-peer transmission, provided+    you inform other peers where the object code and Corresponding+    Source of the work are being offered to the general public at no+    charge under subsection 6d.++  A separable portion of the object code, whose source code is excluded+from the Corresponding Source as a System Library, need not be+included in conveying the object code work.++  A "User Product" is either (1) a "consumer product", which means any+tangible personal property which is normally used for personal, family,+or household purposes, or (2) anything designed or sold for incorporation+into a dwelling.  In determining whether a product is a consumer product,+doubtful cases shall be resolved in favor of coverage.  For a particular+product received by a particular user, "normally used" refers to a+typical or common use of that class of product, regardless of the status+of the particular user or of the way in which the particular user+actually uses, or expects or is expected to use, the product.  A product+is a consumer product regardless of whether the product has substantial+commercial, industrial or non-consumer uses, unless such uses represent+the only significant mode of use of the product.++  "Installation Information" for a User Product means any methods,+procedures, authorization keys, or other information required to install+and execute modified versions of a covered work in that User Product from+a modified version of its Corresponding Source.  The information must+suffice to ensure that the continued functioning of the modified object+code is in no case prevented or interfered with solely because+modification has been made.++  If you convey an object code work under this section in, or with, or+specifically for use in, a User Product, and the conveying occurs as+part of a transaction in which the right of possession and use of the+User Product is transferred to the recipient in perpetuity or for a+fixed term (regardless of how the transaction is characterized), the+Corresponding Source conveyed under this section must be accompanied+by the Installation Information.  But this requirement does not apply+if neither you nor any third party retains the ability to install+modified object code on the User Product (for example, the work has+been installed in ROM).++  The requirement to provide Installation Information does not include a+requirement to continue to provide support service, warranty, or updates+for a work that has been modified or installed by the recipient, or for+the User Product in which it has been modified or installed.  Access to a+network may be denied when the modification itself materially and+adversely affects the operation of the network or violates the rules and+protocols for communication across the network.++  Corresponding Source conveyed, and Installation Information provided,+in accord with this section must be in a format that is publicly+documented (and with an implementation available to the public in+source code form), and must require no special password or key for+unpacking, reading or copying.++  7. Additional Terms.++  "Additional permissions" are terms that supplement the terms of this+License by making exceptions from one or more of its conditions.+Additional permissions that are applicable to the entire Program shall+be treated as though they were included in this License, to the extent+that they are valid under applicable law.  If additional permissions+apply only to part of the Program, that part may be used separately+under those permissions, but the entire Program remains governed by+this License without regard to the additional permissions.++  When you convey a copy of a covered work, you may at your option+remove any additional permissions from that copy, or from any part of+it.  (Additional permissions may be written to require their own+removal in certain cases when you modify the work.)  You may place+additional permissions on material, added by you to a covered work,+for which you have or can give appropriate copyright permission.++  Notwithstanding any other provision of this License, for material you+add to a covered work, you may (if authorized by the copyright holders of+that material) supplement the terms of this License with terms:++    a) Disclaiming warranty or limiting liability differently from the+    terms of sections 15 and 16 of this License; or++    b) Requiring preservation of specified reasonable legal notices or+    author attributions in that material or in the Appropriate Legal+    Notices displayed by works containing it; or++    c) Prohibiting misrepresentation of the origin of that material, or+    requiring that modified versions of such material be marked in+    reasonable ways as different from the original version; or++    d) Limiting the use for publicity purposes of names of licensors or+    authors of the material; or++    e) Declining to grant rights under trademark law for use of some+    trade names, trademarks, or service marks; or++    f) Requiring indemnification of licensors and authors of that+    material by anyone who conveys the material (or modified versions of+    it) with contractual assumptions of liability to the recipient, for+    any liability that these contractual assumptions directly impose on+    those licensors and authors.++  All other non-permissive additional terms are considered "further+restrictions" within the meaning of section 10.  If the Program as you+received it, or any part of it, contains a notice stating that it is+governed by this License along with a term that is a further+restriction, you may remove that term.  If a license document contains+a further restriction but permits relicensing or conveying under this+License, you may add to a covered work material governed by the terms+of that license document, provided that the further restriction does+not survive such relicensing or conveying.++  If you add terms to a covered work in accord with this section, you+must place, in the relevant source files, a statement of the+additional terms that apply to those files, or a notice indicating+where to find the applicable terms.++  Additional terms, permissive or non-permissive, may be stated in the+form of a separately written license, or stated as exceptions;+the above requirements apply either way.++  8. Termination.++  You may not propagate or modify a covered work except as expressly+provided under this License.  Any attempt otherwise to propagate or+modify it is void, and will automatically terminate your rights under+this License (including any patent licenses granted under the third+paragraph of section 11).++  However, if you cease all violation of this License, then your+license from a particular copyright holder is reinstated (a)+provisionally, unless and until the copyright holder explicitly and+finally terminates your license, and (b) permanently, if the copyright+holder fails to notify you of the violation by some reasonable means+prior to 60 days after the cessation.++  Moreover, your license from a particular copyright holder is+reinstated permanently if the copyright holder notifies you of the+violation by some reasonable means, this is the first time you have+received notice of violation of this License (for any work) from that+copyright holder, and you cure the violation prior to 30 days after+your receipt of the notice.++  Termination of your rights under this section does not terminate the+licenses of parties who have received copies or rights from you under+this License.  If your rights have been terminated and not permanently+reinstated, you do not qualify to receive new licenses for the same+material under section 10.++  9. Acceptance Not Required for Having Copies.++  You are not required to accept this License in order to receive or+run a copy of the Program.  Ancillary propagation of a covered work+occurring solely as a consequence of using peer-to-peer transmission+to receive a copy likewise does not require acceptance.  However,+nothing other than this License grants you permission to propagate or+modify any covered work.  These actions infringe copyright if you do+not accept this License.  Therefore, by modifying or propagating a+covered work, you indicate your acceptance of this License to do so.++  10. Automatic Licensing of Downstream Recipients.++  Each time you convey a covered work, the recipient automatically+receives a license from the original licensors, to run, modify and+propagate that work, subject to this License.  You are not responsible+for enforcing compliance by third parties with this License.++  An "entity transaction" is a transaction transferring control of an+organization, or substantially all assets of one, or subdividing an+organization, or merging organizations.  If propagation of a covered+work results from an entity transaction, each party to that+transaction who receives a copy of the work also receives whatever+licenses to the work the party's predecessor in interest had or could+give under the previous paragraph, plus a right to possession of the+Corresponding Source of the work from the predecessor in interest, if+the predecessor has it or can get it with reasonable efforts.++  You may not impose any further restrictions on the exercise of the+rights granted or affirmed under this License.  For example, you may+not impose a license fee, royalty, or other charge for exercise of+rights granted under this License, and you may not initiate litigation+(including a cross-claim or counterclaim in a lawsuit) alleging that+any patent claim is infringed by making, using, selling, offering for+sale, or importing the Program or any portion of it.++  11. Patents.++  A "contributor" is a copyright holder who authorizes use under this+License of the Program or a work on which the Program is based.  The+work thus licensed is called the contributor's "contributor version".++  A contributor's "essential patent claims" are all patent claims+owned or controlled by the contributor, whether already acquired or+hereafter acquired, that would be infringed by some manner, permitted+by this License, of making, using, or selling its contributor version,+but do not include claims that would be infringed only as a+consequence of further modification of the contributor version.  For+purposes of this definition, "control" includes the right to grant+patent sublicenses in a manner consistent with the requirements of+this License.++  Each contributor grants you a non-exclusive, worldwide, royalty-free+patent license under the contributor's essential patent claims, to+make, use, sell, offer for sale, import and otherwise run, modify and+propagate the contents of its contributor version.++  In the following three paragraphs, a "patent license" is any express+agreement or commitment, however denominated, not to enforce a patent+(such as an express permission to practice a patent or covenant not to+sue for patent infringement).  To "grant" such a patent license to a+party means to make such an agreement or commitment not to enforce a+patent against the party.++  If you convey a covered work, knowingly relying on a patent license,+and the Corresponding Source of the work is not available for anyone+to copy, free of charge and under the terms of this License, through a+publicly available network server or other readily accessible means,+then you must either (1) cause the Corresponding Source to be so+available, or (2) arrange to deprive yourself of the benefit of the+patent license for this particular work, or (3) arrange, in a manner+consistent with the requirements of this License, to extend the patent+license to downstream recipients.  "Knowingly relying" means you have+actual knowledge that, but for the patent license, your conveying the+covered work in a country, or your recipient's use of the covered work+in a country, would infringe one or more identifiable patents in that+country that you have reason to believe are valid.++  If, pursuant to or in connection with a single transaction or+arrangement, you convey, or propagate by procuring conveyance of, a+covered work, and grant a patent license to some of the parties+receiving the covered work authorizing them to use, propagate, modify+or convey a specific copy of the covered work, then the patent license+you grant is automatically extended to all recipients of the covered+work and works based on it.++  A patent license is "discriminatory" if it does not include within+the scope of its coverage, prohibits the exercise of, or is+conditioned on the non-exercise of one or more of the rights that are+specifically granted under this License.  You may not convey a covered+work if you are a party to an arrangement with a third party that is+in the business of distributing software, under which you make payment+to the third party based on the extent of your activity of conveying+the work, and under which the third party grants, to any of the+parties who would receive the covered work from you, a discriminatory+patent license (a) in connection with copies of the covered work+conveyed by you (or copies made from those copies), or (b) primarily+for and in connection with specific products or compilations that+contain the covered work, unless you entered into that arrangement,+or that patent license was granted, prior to 28 March 2007.++  Nothing in this License shall be construed as excluding or limiting+any implied license or other defenses to infringement that may+otherwise be available to you under applicable patent law.++  12. No Surrender of Others' Freedom.++  If conditions are imposed on you (whether by court order, agreement or+otherwise) that contradict the conditions of this License, they do not+excuse you from the conditions of this License.  If you cannot convey a+covered work so as to satisfy simultaneously your obligations under this+License and any other pertinent obligations, then as a consequence you may+not convey it at all.  For example, if you agree to terms that obligate you+to collect a royalty for further conveying from those to whom you convey+the Program, the only way you could satisfy both those terms and this+License would be to refrain entirely from conveying the Program.++  13. Use with the GNU Affero General Public License.++  Notwithstanding any other provision of this License, you have+permission to link or combine any covered work with a work licensed+under version 3 of the GNU Affero General Public License into a single+combined work, and to convey the resulting work.  The terms of this+License will continue to apply to the part which is the covered work,+but the special requirements of the GNU Affero General Public License,+section 13, concerning interaction through a network will apply to the+combination as such.++  14. Revised Versions of this License.++  The Free Software Foundation may publish revised and/or new versions of+the GNU General Public License from time to time.  Such new versions will+be similar in spirit to the present version, but may differ in detail to+address new problems or concerns.++  Each version is given a distinguishing version number.  If the+Program specifies that a certain numbered version of the GNU General+Public License "or any later version" applies to it, you have the+option of following the terms and conditions either of that numbered+version or of any later version published by the Free Software+Foundation.  If the Program does not specify a version number of the+GNU General Public License, you may choose any version ever published+by the Free Software Foundation.++  If the Program specifies that a proxy can decide which future+versions of the GNU General Public License can be used, that proxy's+public statement of acceptance of a version permanently authorizes you+to choose that version for the Program.++  Later license versions may give you additional or different+permissions.  However, no additional obligations are imposed on any+author or copyright holder as a result of your choosing to follow a+later version.++  15. Disclaimer of Warranty.++  THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY+APPLICABLE LAW.  EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT+HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY+OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,+THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR+PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM+IS WITH YOU.  SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF+ALL NECESSARY SERVICING, REPAIR OR CORRECTION.++  16. Limitation of Liability.++  IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS+THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY+GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE+USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF+DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD+PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),+EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF+SUCH DAMAGES.++  17. Interpretation of Sections 15 and 16.++  If the disclaimer of warranty and limitation of liability provided+above cannot be given local legal effect according to their terms,+reviewing courts shall apply local law that most closely approximates+an absolute waiver of all civil liability in connection with the+Program, unless a warranty or assumption of liability accompanies a+copy of the Program in return for a fee.++                     END OF TERMS AND CONDITIONS++            How to Apply These Terms to Your New Programs++  If you develop a new program, and you want it to be of the greatest+possible use to the public, the best way to achieve this is to make it+free software which everyone can redistribute and change under these terms.++  To do so, attach the following notices to the program.  It is safest+to attach them to the start of each source file to most effectively+state the exclusion of warranty; and each file should have at least+the "copyright" line and a pointer to where the full notice is found.++    <one line to give the program's name and a brief idea of what it does.>+    Copyright (C) <year>  <name of author>++    This program is free software: you can redistribute it and/or modify+    it under the terms of the GNU General Public License as published by+    the Free Software Foundation, either version 3 of the License, or+    (at your option) any later version.++    This program is distributed in the hope that it will be useful,+    but WITHOUT ANY WARRANTY; without even the implied warranty of+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+    GNU General Public License for more details.++    You should have received a copy of the GNU General Public License+    along with this program.  If not, see <http://www.gnu.org/licenses/>.++Also add information on how to contact you by electronic and paper mail.++  If the program does terminal interaction, make it output a short+notice like this when it starts in an interactive mode:++    <program>  Copyright (C) <year>  <name of author>+    This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.+    This is free software, and you are welcome to redistribute it+    under certain conditions; type `show c' for details.++The hypothetical commands `show w' and `show c' should show the appropriate+parts of the General Public License.  Of course, your program's commands+might be different; for a GUI interface, you would use an "about box".++  You should also get your employer (if you work as a programmer) or school,+if any, to sign a "copyright disclaimer" for the program, if necessary.+For more information on this, and how to apply and follow the GNU GPL, see+<http://www.gnu.org/licenses/>.++  The GNU General Public License does not permit incorporating your program+into proprietary programs.  If your program is a subroutine library, you+may consider it more useful to permit linking proprietary applications with+the library.  If this is what you want to do, use the GNU Lesser General+Public License instead of this License.  But first, please read+<http://www.gnu.org/philosophy/why-not-lgpl.html>.
+ doc/legal/license-libjpeg-turbo.txt view
@@ -0,0 +1,31 @@+*******************************************************************************+**     License+*******************************************************************************++Most of libjpeg-turbo inherits the non-restrictive, BSD-style license used by+libjpeg (see README.)  The TurboJPEG wrapper (both C and Java versions) and+associated test programs bear a similar license, which is reproduced below:++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++- Redistributions of source code must retain the above copyright notice,+  this list of conditions and the following disclaimer.+- Redistributions in binary form must reproduce the above copyright notice,+  this list of conditions and the following disclaimer in the documentation+  and/or other materials provided with the distribution.+- Neither the name of the libjpeg-turbo Project nor the names of its+  contributors may be used to endorse or promote products derived from this+  software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS",+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE+LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR+CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF+SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS+INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN+CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)+ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ doc/legal/license-libjpeg.txt view
@@ -0,0 +1,385 @@+The Independent JPEG Group's JPEG software+==========================================++README for release 6b of 27-Mar-1998+====================================++This distribution contains the sixth public release of the Independent JPEG+Group's free JPEG software.  You are welcome to redistribute this software and+to use it for any purpose, subject to the conditions under LEGAL ISSUES, below.++Serious users of this software (particularly those incorporating it into+larger programs) should contact IJG at jpeg-info@uunet.uu.net to be added to+our electronic mailing list.  Mailing list members are notified of updates+and have a chance to participate in technical discussions, etc.++This software is the work of Tom Lane, Philip Gladstone, Jim Boucher,+Lee Crocker, Julian Minguillon, Luis Ortiz, George Phillips, Davide Rossi,+Guido Vollbeding, Ge' Weijers, and other members of the Independent JPEG+Group.++IJG is not affiliated with the official ISO JPEG standards committee.+++DOCUMENTATION ROADMAP+=====================++This file contains the following sections:++OVERVIEW            General description of JPEG and the IJG software.+LEGAL ISSUES        Copyright, lack of warranty, terms of distribution.+REFERENCES          Where to learn more about JPEG.+ARCHIVE LOCATIONS   Where to find newer versions of this software.+RELATED SOFTWARE    Other stuff you should get.+FILE FORMAT WARS    Software *not* to get.+TO DO               Plans for future IJG releases.++Other documentation files in the distribution are:++User documentation:+  install.doc       How to configure and install the IJG software.+  usage.doc         Usage instructions for cjpeg, djpeg, jpegtran,+                    rdjpgcom, and wrjpgcom.+  *.1               Unix-style man pages for programs (same info as usage.doc).+  wizard.doc        Advanced usage instructions for JPEG wizards only.+  change.log        Version-to-version change highlights.+Programmer and internal documentation:+  libjpeg.doc       How to use the JPEG library in your own programs.+  example.c         Sample code for calling the JPEG library.+  structure.doc     Overview of the JPEG library's internal structure.+  filelist.doc      Road map of IJG files.+  coderules.doc     Coding style rules --- please read if you contribute code.++Please read at least the files install.doc and usage.doc.  Useful information+can also be found in the JPEG FAQ (Frequently Asked Questions) article.  See+ARCHIVE LOCATIONS below to find out where to obtain the FAQ article.++If you want to understand how the JPEG code works, we suggest reading one or+more of the REFERENCES, then looking at the documentation files (in roughly+the order listed) before diving into the code.+++OVERVIEW+========++This package contains C software to implement JPEG image compression and+decompression.  JPEG (pronounced "jay-peg") is a standardized compression+method for full-color and gray-scale images.  JPEG is intended for compressing+"real-world" scenes; line drawings, cartoons and other non-realistic images+are not its strong suit.  JPEG is lossy, meaning that the output image is not+exactly identical to the input image.  Hence you must not use JPEG if you+have to have identical output bits.  However, on typical photographic images,+very good compression levels can be obtained with no visible change, and+remarkably high compression levels are possible if you can tolerate a+low-quality image.  For more details, see the references, or just experiment+with various compression settings.++This software implements JPEG baseline, extended-sequential, and progressive+compression processes.  Provision is made for supporting all variants of these+processes, although some uncommon parameter settings aren't implemented yet.+For legal reasons, we are not distributing code for the arithmetic-coding+variants of JPEG; see LEGAL ISSUES.  We have made no provision for supporting+the hierarchical or lossless processes defined in the standard.++We provide a set of library routines for reading and writing JPEG image files,+plus two sample applications "cjpeg" and "djpeg", which use the library to+perform conversion between JPEG and some other popular image file formats.+The library is intended to be reused in other applications.++In order to support file conversion and viewing software, we have included+considerable functionality beyond the bare JPEG coding/decoding capability;+for example, the color quantization modules are not strictly part of JPEG+decoding, but they are essential for output to colormapped file formats or+colormapped displays.  These extra functions can be compiled out of the+library if not required for a particular application.  We have also included+"jpegtran", a utility for lossless transcoding between different JPEG+processes, and "rdjpgcom" and "wrjpgcom", two simple applications for+inserting and extracting textual comments in JFIF files.++The emphasis in designing this software has been on achieving portability and+flexibility, while also making it fast enough to be useful.  In particular,+the software is not intended to be read as a tutorial on JPEG.  (See the+REFERENCES section for introductory material.)  Rather, it is intended to+be reliable, portable, industrial-strength code.  We do not claim to have+achieved that goal in every aspect of the software, but we strive for it.++We welcome the use of this software as a component of commercial products.+No royalty is required, but we do ask for an acknowledgement in product+documentation, as described under LEGAL ISSUES.+++LEGAL ISSUES+============++In plain English:++1. We don't promise that this software works.  (But if you find any bugs,+   please let us know!)+2. You can use this software for whatever you want.  You don't have to pay us.+3. You may not pretend that you wrote this software.  If you use it in a+   program, you must acknowledge somewhere in your documentation that+   you've used the IJG code.++In legalese:++The authors make NO WARRANTY or representation, either express or implied,+with respect to this software, its quality, accuracy, merchantability, or+fitness for a particular purpose.  This software is provided "AS IS", and you,+its user, assume the entire risk as to its quality and accuracy.++This software is copyright (C) 1991-1998, Thomas G. Lane.+All Rights Reserved except as specified below.++Permission is hereby granted to use, copy, modify, and distribute this+software (or portions thereof) for any purpose, without fee, subject to these+conditions:+(1) If any part of the source code for this software is distributed, then this+README file must be included, with this copyright and no-warranty notice+unaltered; and any additions, deletions, or changes to the original files+must be clearly indicated in accompanying documentation.+(2) If only executable code is distributed, then the accompanying+documentation must state that "this software is based in part on the work of+the Independent JPEG Group".+(3) Permission for use of this software is granted only if the user accepts+full responsibility for any undesirable consequences; the authors accept+NO LIABILITY for damages of any kind.++These conditions apply to any software derived from or based on the IJG code,+not just to the unmodified library.  If you use our work, you ought to+acknowledge us.++Permission is NOT granted for the use of any IJG author's name or company name+in advertising or publicity relating to this software or products derived from+it.  This software may be referred to only as "the Independent JPEG Group's+software".++We specifically permit and encourage the use of this software as the basis of+commercial products, provided that all warranty or liability claims are+assumed by the product vendor.+++ansi2knr.c is included in this distribution by permission of L. Peter Deutsch,+sole proprietor of its copyright holder, Aladdin Enterprises of Menlo Park, CA.+ansi2knr.c is NOT covered by the above copyright and conditions, but instead+by the usual distribution terms of the Free Software Foundation; principally,+that you must include source code if you redistribute it.  (See the file+ansi2knr.c for full details.)  However, since ansi2knr.c is not needed as part+of any program generated from the IJG code, this does not limit you more than+the foregoing paragraphs do.++The Unix configuration script "configure" was produced with GNU Autoconf.+It is copyright by the Free Software Foundation but is freely distributable.+The same holds for its supporting scripts (config.guess, config.sub,+ltconfig, ltmain.sh).  Another support script, install-sh, is copyright+by M.I.T. but is also freely distributable.++It appears that the arithmetic coding option of the JPEG spec is covered by+patents owned by IBM, AT&T, and Mitsubishi.  Hence arithmetic coding cannot+legally be used without obtaining one or more licenses.  For this reason,+support for arithmetic coding has been removed from the free JPEG software.+(Since arithmetic coding provides only a marginal gain over the unpatented+Huffman mode, it is unlikely that very many implementations will support it.)+So far as we are aware, there are no patent restrictions on the remaining+code.++The IJG distribution formerly included code to read and write GIF files.+To avoid entanglement with the Unisys LZW patent, GIF reading support has+been removed altogether, and the GIF writer has been simplified to produce+"uncompressed GIFs".  This technique does not use the LZW algorithm; the+resulting GIF files are larger than usual, but are readable by all standard+GIF decoders.++We are required to state that+    "The Graphics Interchange Format(c) is the Copyright property of+    CompuServe Incorporated.  GIF(sm) is a Service Mark property of+    CompuServe Incorporated."+++REFERENCES+==========++We highly recommend reading one or more of these references before trying to+understand the innards of the JPEG software.++The best short technical introduction to the JPEG compression algorithm is+	Wallace, Gregory K.  "The JPEG Still Picture Compression Standard",+	Communications of the ACM, April 1991 (vol. 34 no. 4), pp. 30-44.+(Adjacent articles in that issue discuss MPEG motion picture compression,+applications of JPEG, and related topics.)  If you don't have the CACM issue+handy, a PostScript file containing a revised version of Wallace's article is+available at ftp://ftp.uu.net/graphics/jpeg/wallace.ps.gz.  The file (actually+a preprint for an article that appeared in IEEE Trans. Consumer Electronics)+omits the sample images that appeared in CACM, but it includes corrections+and some added material.  Note: the Wallace article is copyright ACM and IEEE,+and it may not be used for commercial purposes.++A somewhat less technical, more leisurely introduction to JPEG can be found in+"The Data Compression Book" by Mark Nelson and Jean-loup Gailly, published by+M&T Books (New York), 2nd ed. 1996, ISBN 1-55851-434-1.  This book provides+good explanations and example C code for a multitude of compression methods+including JPEG.  It is an excellent source if you are comfortable reading C+code but don't know much about data compression in general.  The book's JPEG+sample code is far from industrial-strength, but when you are ready to look+at a full implementation, you've got one here...++The best full description of JPEG is the textbook "JPEG Still Image Data+Compression Standard" by William B. Pennebaker and Joan L. Mitchell, published+by Van Nostrand Reinhold, 1993, ISBN 0-442-01272-1.  Price US$59.95, 638 pp.+The book includes the complete text of the ISO JPEG standards (DIS 10918-1+and draft DIS 10918-2).  This is by far the most complete exposition of JPEG+in existence, and we highly recommend it.++The JPEG standard itself is not available electronically; you must order a+paper copy through ISO or ITU.  (Unless you feel a need to own a certified+official copy, we recommend buying the Pennebaker and Mitchell book instead;+it's much cheaper and includes a great deal of useful explanatory material.)+In the USA, copies of the standard may be ordered from ANSI Sales at (212)+642-4900, or from Global Engineering Documents at (800) 854-7179.  (ANSI+doesn't take credit card orders, but Global does.)  It's not cheap: as of+1992, ANSI was charging $95 for Part 1 and $47 for Part 2, plus 7%+shipping/handling.  The standard is divided into two parts, Part 1 being the+actual specification, while Part 2 covers compliance testing methods.  Part 1+is titled "Digital Compression and Coding of Continuous-tone Still Images,+Part 1: Requirements and guidelines" and has document numbers ISO/IEC IS+10918-1, ITU-T T.81.  Part 2 is titled "Digital Compression and Coding of+Continuous-tone Still Images, Part 2: Compliance testing" and has document+numbers ISO/IEC IS 10918-2, ITU-T T.83.++Some extensions to the original JPEG standard are defined in JPEG Part 3,+a newer ISO standard numbered ISO/IEC IS 10918-3 and ITU-T T.84.  IJG+currently does not support any Part 3 extensions.++The JPEG standard does not specify all details of an interchangeable file+format.  For the omitted details we follow the "JFIF" conventions, revision+1.02.  A copy of the JFIF spec is available from:+	Literature Department+	C-Cube Microsystems, Inc.+	1778 McCarthy Blvd.+	Milpitas, CA 95035+	phone (408) 944-6300,  fax (408) 944-6314+A PostScript version of this document is available by FTP at+ftp://ftp.uu.net/graphics/jpeg/jfif.ps.gz.  There is also a plain text+version at ftp://ftp.uu.net/graphics/jpeg/jfif.txt.gz, but it is missing+the figures.++The TIFF 6.0 file format specification can be obtained by FTP from+ftp://ftp.sgi.com/graphics/tiff/TIFF6.ps.gz.  The JPEG incorporation scheme+found in the TIFF 6.0 spec of 3-June-92 has a number of serious problems.+IJG does not recommend use of the TIFF 6.0 design (TIFF Compression tag 6).+Instead, we recommend the JPEG design proposed by TIFF Technical Note #2+(Compression tag 7).  Copies of this Note can be obtained from ftp.sgi.com or+from ftp://ftp.uu.net/graphics/jpeg/.  It is expected that the next revision+of the TIFF spec will replace the 6.0 JPEG design with the Note's design.+Although IJG's own code does not support TIFF/JPEG, the free libtiff library+uses our library to implement TIFF/JPEG per the Note.  libtiff is available+from ftp://ftp.sgi.com/graphics/tiff/.+++ARCHIVE LOCATIONS+=================++The "official" archive site for this software is ftp.uu.net (Internet+address 192.48.96.9).  The most recent released version can always be found+there in directory graphics/jpeg.  This particular version will be archived+as ftp://ftp.uu.net/graphics/jpeg/jpegsrc.v6b.tar.gz.  If you don't have+direct Internet access, UUNET's archives are also available via UUCP; contact+help@uunet.uu.net for information on retrieving files that way.++Numerous Internet sites maintain copies of the UUNET files.  However, only+ftp.uu.net is guaranteed to have the latest official version.++You can also obtain this software in DOS-compatible "zip" archive format from+the SimTel archives (ftp://ftp.simtel.net/pub/simtelnet/msdos/graphics/), or+on CompuServe in the Graphics Support forum (GO CIS:GRAPHSUP), library 12+"JPEG Tools".  Again, these versions may sometimes lag behind the ftp.uu.net+release.++The JPEG FAQ (Frequently Asked Questions) article is a useful source of+general information about JPEG.  It is updated constantly and therefore is+not included in this distribution.  The FAQ is posted every two weeks to+Usenet newsgroups comp.graphics.misc, news.answers, and other groups.+It is available on the World Wide Web at http://www.faqs.org/faqs/jpeg-faq/+and other news.answers archive sites, including the official news.answers+archive at rtfm.mit.edu: ftp://rtfm.mit.edu/pub/usenet/news.answers/jpeg-faq/.+If you don't have Web or FTP access, send e-mail to mail-server@rtfm.mit.edu+with body+	send usenet/news.answers/jpeg-faq/part1+	send usenet/news.answers/jpeg-faq/part2+++RELATED SOFTWARE+================++Numerous viewing and image manipulation programs now support JPEG.  (Quite a+few of them use this library to do so.)  The JPEG FAQ described above lists+some of the more popular free and shareware viewers, and tells where to+obtain them on Internet.++If you are on a Unix machine, we highly recommend Jef Poskanzer's free+PBMPLUS software, which provides many useful operations on PPM-format image+files.  In particular, it can convert PPM images to and from a wide range of+other formats, thus making cjpeg/djpeg considerably more useful.  The latest+version is distributed by the NetPBM group, and is available from numerous+sites, notably ftp://wuarchive.wustl.edu/graphics/graphics/packages/NetPBM/.+Unfortunately PBMPLUS/NETPBM is not nearly as portable as the IJG software is;+you are likely to have difficulty making it work on any non-Unix machine.++A different free JPEG implementation, written by the PVRG group at Stanford,+is available from ftp://havefun.stanford.edu/pub/jpeg/.  This program+is designed for research and experimentation rather than production use;+it is slower, harder to use, and less portable than the IJG code, but it+is easier to read and modify.  Also, the PVRG code supports lossless JPEG,+which we do not.  (On the other hand, it doesn't do progressive JPEG.)+++FILE FORMAT WARS+================++Some JPEG programs produce files that are not compatible with our library.+The root of the problem is that the ISO JPEG committee failed to specify a+concrete file format.  Some vendors "filled in the blanks" on their own,+creating proprietary formats that no one else could read.  (For example, none+of the early commercial JPEG implementations for the Macintosh were able to+exchange compressed files.)++The file format we have adopted is called JFIF (see REFERENCES).  This format+has been agreed to by a number of major commercial JPEG vendors, and it has+become the de facto standard.  JFIF is a minimal or "low end" representation.+We recommend the use of TIFF/JPEG (TIFF revision 6.0 as modified by TIFF+Technical Note #2) for "high end" applications that need to record a lot of+additional data about an image.  TIFF/JPEG is fairly new and not yet widely+supported, unfortunately.++The upcoming JPEG Part 3 standard defines a file format called SPIFF.+SPIFF is interoperable with JFIF, in the sense that most JFIF decoders should+be able to read the most common variant of SPIFF.  SPIFF has some technical+advantages over JFIF, but its major claim to fame is simply that it is an+official standard rather than an informal one.  At this point it is unclear+whether SPIFF will supersede JFIF or whether JFIF will remain the de-facto+standard.  IJG intends to support SPIFF once the standard is frozen, but we+have not decided whether it should become our default output format or not.+(In any case, our decoder will remain capable of reading JFIF indefinitely.)++Various proprietary file formats incorporating JPEG compression also exist.+We have little or no sympathy for the existence of these formats.  Indeed,+one of the original reasons for developing this free software was to help+force convergence on common, open format standards for JPEG files.  Don't+use a proprietary file format!+++TO DO+=====++The major thrust for v7 will probably be improvement of visual quality.+The current method for scaling the quantization tables is known not to be+very good at low Q values.  We also intend to investigate block boundary+smoothing, "poor man's variable quantization", and other means of improving+quality-vs-file-size performance without sacrificing compatibility.++In future versions, we are considering supporting some of the upcoming JPEG+Part 3 extensions --- principally, variable quantization and the SPIFF file+format.++As always, speeding things up is of great interest.++Please send bug reports, offers of help, etc. to jpeg-info@uunet.uu.net.
+ doc/legal/license-miniz.txt view
@@ -0,0 +1,22 @@+Copyright 2013-2014 RAD Game Tools and Valve Software+Copyright 2010-2014 Rich Geldreich and Tenacious Software LLC++All Rights Reserved.++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.
+ doc/legal/license-octocat.md view
@@ -0,0 +1,27 @@+The OCTOCAT® logo design is an exclusive trademark registered in the United States by GitHub, Inc and is used in Neverball with permission. More details on Octocat usage can be found on the GitHub website at https://github.com/logos++Special authorisation to use Octocat in Neverball was requested in November 2013 and given by GitHub according to the following dialogue.+++Request made by Josh "Cheeseness" Bush on behalf of the Neverball community:+> Hi there! We've just moved our F/OSS project [Neverball](https://github.com/Neverball/neverball) to GitHub and would  like to add an Octocat themed bonus ball in the game to celebrate.++> I have made a work-in-progress ball, but would like to seek permission before including it in the game, as it seems to be outside the preferred usage.++> ![screen00011](https://f.cloud.github.com/assets/1570520/1541274/769b1678-4d32-11e3-9ae3-ec80c46e414a.png)++> Many thanks <3++> Cheese+++Response from Haleigh on behalf of GitHub Staff:+> Hi Cheese,++> I bring you rad tidings from the Octocat-tamers! It's totally cool for you to include the Octocat bonus ball in the way you've outlined.++> Thanks so much for checking in with us first, and happy new-GitHub-home to Neverball!++> Cheers,++> Haleigh
+ doc/legal/license-vorbis.txt view
@@ -0,0 +1,28 @@+Copyright (c) 2002-2008 Xiph.org Foundation++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++- Redistributions of source code must retain the above copyright+notice, this list of conditions and the following disclaimer.++- Redistributions in binary form must reproduce the above copyright+notice, this list of conditions and the following disclaimer in the+documentation and/or other materials provided with the distribution.++- Neither the name of the Xiph.org Foundation nor the names of its+contributors may be used to endorse or promote products derived from+this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE FOUNDATION+OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ doc/screenshots/readme-screenshot0-v0.1.0.1.png view

binary file changed (absent → 261187 bytes)

+ immutaball-core.cabal view
@@ -0,0 +1,264 @@+cabal-version: 3.0++name: immutaball-core+version: 0.1.0.4.1++synopsis: Immutaball platformer game+description:+    The Immutaball platformer game is a rewrite of Neverball in Haskell.+category:     Games+homepage:     https://nibzdil.org/+bug-reports:  https://nibzdil.org/++-- When packaged with Neverball data (e.g. into ‘immutaball’), distribute under+-- GPL terms to be compliant.+license:      0BSD+license-file: LICENSE.md+author:       Byron Johnson+maintainer:   bjohnson@nibzdil.org+build-type:   Simple+copyright:    2024, Byron Johnson++extra-source-files:+    README.md+extra-doc-files:+    doc/legal/*.md+    doc/legal/*.txt+    doc/screenshots/*.png++source-repository head+    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++flag add-default-compiler-flags+    description:+        Add default set of compiler flags.+    default: True+    manual: True++common all-components+    default-language: Haskell2010+    other-extensions:+        TemplateHaskell+        TypeSynonymInstances+        FlexibleInstances+        InstanceSigs+        ScopedTypeVariables+        UndecidableInstances+        RankNTypes+        Arrows+        DerivingVia+        FlexibleContexts+        ExistentialQuantification+        ExplicitForAll+        NondecreasingIndentation++    hs-source-dirs: .++    -- We use multiple threads.  Include to fix this error:+    -- > user error (RTS doesn't support multiple OS threads (use ghc -threaded when linking))+    -- >+    -- > Package: ghc-internal+    -- > Module: GHC.Internal.IO.Exception+    -- > Type: IOException+    ghc-options: -threaded++    if flag(add-default-compiler-flags)+        -- Disable tab warner.+        -- It's a better style: https://dmitryfrank.com/articles/indent_with_tabs_align_with_spaces+        ghc-options: -Wall -Wno-tabs+        -- ghc-options: -O2++    build-depends:+        base             >= 4.9      && < 9.5,+        bytestring       >= 0.11.0.0 && < 0.13,+        containers       >= 0.6.0.1  && < 0.8,+        transformers     >= 0.5.0.0  && < 0.7,+        pipes            >= 4.3.16   && < 4.4,+        lens             >= 5.3.2    && < 5.4,+        parallel         >= 3.2.2.0  && < 3.3,+        --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,+        mtl              >= 2.2      && < 2.4,+        --filepath         >= 1.5.3.0  && < 1.6,+        filepath         >= 1.4.2.2  && < 1.6,+        --directory        >= 1.3.8.5  && < 1.4,+        directory        >= 1.3.8.4  && < 1.4,+        prettyprinter    >= 1.7.1    && < 1.8,+        parsec           >= 3.1.17.0 && < 3.2,+        unbounded-delays >= 0.1.1.1  && < 0.2,+        time             >= 1.12     && < 1.15,++        sdl2             >= 2.5.5.0  && < 2.6,+        gl               >= 0.9      && < 0.10,+        array            >= 0.5.8.0  && < 0.6,+        OpenGL           >= 3.0.3.0  && < 3.1,+        sdl2-ttf         >= 2.1.3    && < 2.2,+        libvorbis        >= 0.1.0.2  && < 0.2,+        JuicyPixels      >= 3.3.9    && < 3.4,+        curl             >= 1.3.8    && < 1.3.9,+        i18n             >= 0.4.0.0  && < 0.5,+        text             >= 2.1      && < 2.2++common executable-components+    build-depends: immutaball-core++    other-modules:+        Control.Monad.Trans.MaybeM+        Immutaball.Ball.CLI+        Immutaball.Ball.CLI.Config+        Immutaball.Ball.Game+        Immutaball.Ball.LevelSets+        Immutaball.Ball.Main+        Immutaball.Ball.State.Game+        Immutaball.Ball.State.LevelSelect+        Immutaball.Ball.State.LevelSets+        Immutaball.Ball.State.Play+        Immutaball.Ball.State.Preplay+        Immutaball.Ball.State.Title+        Immutaball.Prelude+        Immutaball.Putt.CLI+        Immutaball.Putt.CLI.Config+        Immutaball.Putt.Main+        Immutaball.Share.AutoPar+        Immutaball.Share.Config+        Immutaball.Share.Config.Parser+        Immutaball.Share.Config.Printer+        Immutaball.Share.Context+        Immutaball.Share.Context.Config+        Immutaball.Share.Controller+        Immutaball.Share.GLManager+        Immutaball.Share.GLManager.Config+        Immutaball.Share.GLManager.Types+        Immutaball.Share.GUI+        Immutaball.Share.ImmutaballIO+        Immutaball.Share.ImmutaballIO.BasicIO+        Immutaball.Share.ImmutaballIO.DirectoryIO+        Immutaball.Share.ImmutaballIO.GLIO+        Immutaball.Share.ImmutaballIO.SDLIO+        Immutaball.Share.Level+        Immutaball.Share.Level.Analysis+        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+        Immutaball.Share.Math.Core+        Immutaball.Share.Math.X3D+        Immutaball.Share.SDLManager+        Immutaball.Share.SDLManager.Config+        Immutaball.Share.SDLManager.Types+        Immutaball.Share.State+        Immutaball.Share.State.Context+        Immutaball.Share.Utils+        Immutaball.Share.Video+        Immutaball.Share.Video.LowLevel+        Immutaball.Share.Video.Shaders+        Immutaball.Share.Wire++executable immutaball+    import: all-components+    import: executable-components++    main-is: Main.hs++executable immutaputt+    import: all-components+    import: executable-components++    main-is: Putt.hs++library+    import: all-components++    exposed-modules:+        Control.Monad.Trans.MaybeM+        Immutaball.Ball.CLI+        Immutaball.Ball.CLI.Config+        Immutaball.Ball.Game+        Immutaball.Ball.LevelSets+        Immutaball.Ball.Main+        Immutaball.Ball.State.Game+        Immutaball.Ball.State.LevelSelect+        Immutaball.Ball.State.LevelSets+        Immutaball.Ball.State.Play+        Immutaball.Ball.State.Preplay+        Immutaball.Ball.State.Title+        Immutaball.Prelude+        Immutaball.Putt.CLI+        Immutaball.Putt.CLI.Config+        Immutaball.Putt.Main+        Immutaball.Share.AutoPar+        Immutaball.Share.Config+        Immutaball.Share.Config.Parser+        Immutaball.Share.Config.Printer+        Immutaball.Share.Context+        Immutaball.Share.Context.Config+        Immutaball.Share.Controller+        Immutaball.Share.GLManager+        Immutaball.Share.GLManager.Config+        Immutaball.Share.GLManager.Types+        Immutaball.Share.GUI+        Immutaball.Share.ImmutaballIO+        Immutaball.Share.ImmutaballIO.BasicIO+        Immutaball.Share.ImmutaballIO.DirectoryIO+        Immutaball.Share.ImmutaballIO.GLIO+        Immutaball.Share.ImmutaballIO.SDLIO+        Immutaball.Share.Level+        Immutaball.Share.Level.Analysis+        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+        Immutaball.Share.Math.Core+        Immutaball.Share.Math.X3D+        Immutaball.Share.SDLManager+        Immutaball.Share.SDLManager.Config+        Immutaball.Share.SDLManager.Types+        Immutaball.Share.State+        Immutaball.Share.State.Context+        Immutaball.Share.Utils+        Immutaball.Share.Video+        Immutaball.Share.Video.LowLevel+        Immutaball.Share.Video.Shaders+        Immutaball.Share.Wire++test-suite test-immutaball+    import: all-components+    import: executable-components++    type: exitcode-stdio-1.0++    main-is: Test.hs++    build-depends:+        -- tasty: avoid deprecated 1.5.1 version.+        --tasty            >= 1.5      && < 1.6,+        tasty            (>= 1.5     && < 1.5.1) || (> 1.5.1 && < 1.6),+        tasty-hunit      >= 0.10.2   && < 0.11,+        tasty-quickcheck >= 0.11     && < 0.12,+        HUnit            >= 1.6.2.0  && < 1.7,+        QuickCheck       >= 2.15.0.1 && < 2.16++    other-modules:+        Test.Immutaball.Test+        Test.Immutaball.Share.Math.Core.Orphans+        Test.Immutaball.Share.Math.Core.Test+        Test.Immutaball.Share.Math.Orphans+        Test.Immutaball.Share.Math.Test+        Test.Immutaball.Share.Math.X3D.Test+        Test.Immutaball.Share.State.Fixtures+        Test.Immutaball.Share.State.Test+        Test.Immutaball.Share.Wire.Test