diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,8 @@ +# Changelog + +This project adheres to [Haskell PVP](https://pvp.haskell.org/). + + +## 0.1.0.2 [2018-01-01] + +- Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Olivier Sohn (c) 2017 - 2018 + +All rights reserved. + +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 Olivier Sohn nor the names of other + 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 +OWNER 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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,12 @@ +# What is it? + +A game-engine library containing: + +- Types and classes about discrete and continuous geometry, collision detection, +animated UIs, animated colored text and easing functions. + +- A renderer (delta-renderer) optimized to avoid screen tearing in the terminal. + +- IO utilities to read player key-presses. + +Also produces a demo-application on text animation, `imj-base-examples-exe`. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/example/Main.hs b/example/Main.hs new file mode 100644 --- /dev/null +++ b/example/Main.hs @@ -0,0 +1,22 @@ + +{- | This application runs in the terminal, and shows animated text examples. + +In particular, it shows examples using these functions: + +* 'mkSequentialTextTranslationsCharAnchored' / 'renderAnimatedTextCharAnchored' +* 'mkSequentialTextTranslationsStringAnchored' / 'renderAnimatedTextStringAnchored' +-} + +module Main where + +import Control.Monad.Reader(runReaderT) + +import Imj.Graphics.Render.Delta(runThenRestoreConsoleSettings, newDefaultEnv) + +import Imj.Example.SequentialTextTranslationsAnchored + +main :: IO () +main = do + runThenRestoreConsoleSettings $ + newDefaultEnv + >>= runReaderT exampleOfsequentialTextTranslationsAnchored diff --git a/imj-base.cabal b/imj-base.cabal new file mode 100644 --- /dev/null +++ b/imj-base.cabal @@ -0,0 +1,154 @@ +name: imj-base +version: 0.1.0.2 +Category: Animation, Game Engine, Graphics, Algorithms, Mathematics, + Optimisation, Optimization, User Interface, Terminal +Synopsis: Game engine with geometry, easing, animated text, delta rendering. +Description: Game engine that is intended to help implementing games + for the terminal. + . + + Contains types and classes about discrete and continuous + geometry, collision detection, animated UIs, + animated colored text and easing functions. + . + + Also contains a renderer (delta-renderer) optimized to avoid + screen tearing in the terminal. +homepage: https://github.com/OlivierSohn/hamazed/blob/master/imj-base/README.md +bug-reports: https://github.com/OlivierSohn/hamazed/issues/ +license: BSD3 +license-file: LICENSE +author: Olivier Sohn +maintainer: olivier.sohn@gmail.com +copyright: 2017 - 2018 Olivier Sohn +build-type: Simple +extra-source-files: README.md CHANGELOG.md +cabal-version: >=1.10 + +Tested-With: GHC == 8.0.2, GHC == 8.2.2 + +library + hs-source-dirs: src + other-modules: + exposed-modules: Imj.Data.Vector.Unboxed.Mutable.Dynamic + , Imj.Example.DeltaRender.FromMonadIO + , Imj.Example.DeltaRender.FromMonadReader + , Imj.Example.SequentialTextTranslationsAnchored + , Imj.GameItem.Weapon.Laser.Types + , Imj.GameItem.Weapon.Laser + , Imj.Geo.Discrete + , Imj.Geo.Discrete.Bresenham + , Imj.Geo.Discrete.Bresenham3 + , Imj.Geo.Discrete.Resample + , Imj.Geo.Discrete.Types + , Imj.Geo.Continuous + , Imj.Geo.Continuous.Conversion + , Imj.Geo.Continuous.Types + , Imj.Geo.Types + , Imj.Graphics.Class + , Imj.Graphics.Class.Colorable + , Imj.Graphics.Class.DiscreteColorableMorphing + , Imj.Graphics.Class.DiscreteInterpolation + , Imj.Graphics.Class.DiscreteMorphing + , Imj.Graphics.Class.Drawable + , Imj.Graphics.Class.Draw + , Imj.Graphics.Class.HasLayeredColor + , Imj.Graphics.Class.Render + , Imj.Graphics.Class.DiscreteDistance + , Imj.Graphics.Color + , Imj.Graphics.Color.Types + , Imj.Graphics.Render + , Imj.Graphics.Render.FromMonadReader + , Imj.Graphics.Interpolation + , Imj.Graphics.Interpolation.SequentiallyInterpolatedList + , Imj.Graphics.Interpolation.Evolution + , Imj.Graphics.Math.Ease + , Imj.Graphics.Render.Delta + , Imj.Graphics.Render.Delta.Buffers + , Imj.Graphics.Render.Delta.Buffers.Dimensions + , Imj.Graphics.Render.Delta.Cell + , Imj.Graphics.Render.Delta.Cells + , Imj.Graphics.Render.Delta.Clear + , Imj.Graphics.Render.Delta.Console + , Imj.Graphics.Render.Delta.DefaultPolicies + , Imj.Graphics.Render.Delta.Draw + , Imj.Graphics.Render.Delta.Env + , Imj.Graphics.Render.Delta.Flush + , Imj.Graphics.Render.Delta.Internal.Types + , Imj.Graphics.Render.Delta.Types + , Imj.Graphics.Render.Naive + , Imj.Graphics.Text.Alignment + , Imj.Graphics.Text.Animation + , Imj.Graphics.Text.ColorString + , Imj.Graphics.Text.ColorString.Interpolation + , Imj.Graphics.UI.Animation + , Imj.Graphics.UI.Colored + , Imj.Graphics.UI.RectContainer + , Imj.Graphics.UI.RectContainer.MorphParallel4 + , Imj.Input + , Imj.Input.Blocking + , Imj.Input.NonBlocking + , Imj.Input.Types + , Imj.Iteration + , Imj.Physics.Discrete + , Imj.Physics.Discrete.Collision + , Imj.Physics.Discrete.Types + , Imj.Threading + , Imj.Timing + , Imj.Util + build-depends: base >= 4.8 && < 4.11 + , ansi-terminal >= 0.6.3.1 && < 0.9 + , imj-prelude ==0.1.* + , mtl >= 2.2.1 && < 2.3 + , primitive ==0.6.* + , random ==1.1.* + , terminal-size >= 0.3.2.1 && < 0.3.3 + , text ==1.2.* + , time ==1.8.* + , text ==1.2.* + , vector >= 0.12.0.1 && < 0.12.1 + , vector-algorithms >= 0.7.0.1 && < 0.8 + ghc-options: -Wall -fpedantic-bottoms -Wredundant-constraints + -fexcess-precision -optc-ffast-math + default-language: Haskell2010 + +executable imj-base-examples-exe + hs-source-dirs: example + other-modules: + main-is: Main.hs + build-depends: base >= 4.8 && < 4.11 + , ansi-terminal >= 0.6.3.1 && < 0.9 + , mtl >= 2.2.1 && < 2.3 + , text ==1.2.* + , imj-base + , imj-prelude ==0.1.* + , time ==1.8.* + ghc-options: -Wall -fpedantic-bottoms -Wredundant-constraints + -fexcess-precision -optc-ffast-math + default-language: Haskell2010 + +test-suite imj-base-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + other-modules: Test.Imj.Bresenham3 + , Test.Imj.Ease + , Test.Imj.InterpolatedColorString + , Test.Imj.Interpolation + , Test.Imj.Timing + , Test.Imj.Vector + main-is: Spec.hs + build-depends: base >= 4.8 && < 4.11 + , ansi-terminal >= 0.6.3.1 && < 0.9 + , mtl >= 2.2.1 && < 2.3 + , text ==1.2.* + , imj-base + , imj-prelude ==0.1.* + , time ==1.8.* + ghc-options: -Wall -fpedantic-bottoms -Wredundant-constraints + -fexcess-precision -optc-ffast-math + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/OlivierSohn/hamazed/ + subdir: imj-base diff --git a/src/Imj/Data/Vector/Unboxed/Mutable/Dynamic.hs b/src/Imj/Data/Vector/Unboxed/Mutable/Dynamic.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Data/Vector/Unboxed/Mutable/Dynamic.hs @@ -0,0 +1,172 @@ +{-# OPTIONS_HADDOCK hide #-} + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE NoImplicitPrelude #-} + +{- | A wrapper around 'Data.Vector.Unboxed.Mutable' that enables reserving, +clearing, pushing (in C++ STL vector fashion). + +Modified from https://hackage.haskell.org/package/dynamic-mvector-0.1.0.5/docs/src/Data-Vector-Mutable-Dynamic.html : + +* Adapted to use unboxed vectors +* Added a sort function. +* Added 'accessUnderlying' to be able to use sort algorithms efficiently, without copying. +* Changed behaviour of clear, to avoid reallocation. +* Fixed new / unsafeNew (the size was equal to the capacity instead of zero). +* Removed functions that I don't use and won't have time to support. + +Unit tests : "Test.Imj.Vector" +-} + + +module Imj.Data.Vector.Unboxed.Mutable.Dynamic( + STVector + , IOVector + -- * Creation + , new + + -- * Access + , read + , unsafeRead + , length + , capacity + + -- * Modify + , clear + , pushBack + , unstableSort + , accessUnderlying + + ) where + + +import Imj.Prelude + +import Data.Data(Typeable) +import Data.Vector.Algorithms.Intro(sort) -- unstable sort + +import Control.Monad.Primitive(RealWorld, PrimMonad, PrimState) +import Data.Primitive.MutVar(MutVar, readMutVar, newMutVar, writeMutVar) + +import qualified Data.Vector.Unboxed.Mutable as MV(MVector, take, length, new, unsafeRead, + unsafeGrow, unsafeWrite) +import qualified Data.Vector.Unboxed as V(Unbox) + + +-- | Mutable vector with dynamic behaviour living in the ST or IO monad. +newtype MVector s a = MVector (MutVar s (MVectorData s a)) deriving (Typeable) + +type IOVector = MVector RealWorld +type STVector = MVector + +data MVectorData s a = MVectorData { + _mVectorDatasize :: {-# UNPACK #-} !Int, + _mVectorDataBuffer :: !(MV.MVector s a)} + deriving (Typeable) + +-- | O(1) access to the underlying vector +{-# INLINABLE accessUnderlying #-} +accessUnderlying :: (PrimMonad m, V.Unbox a) + => MVector (PrimState m) a + -> m (MV.MVector (PrimState m) a) +accessUnderlying (MVector v') = + readMutVar v' + >>= + \(MVectorData sz v) -> return $ MV.take sz v + + +-- | O(N*log(N)) unstable sort. +unstableSort :: (PrimMonad m, V.Unbox a, Ord a) + => MVector (PrimState m) a + -> m () +unstableSort v = + accessUnderlying v + >>= sort +{-# INLINABLE unstableSort #-} + +-- | Number of elements in the vector. +length :: PrimMonad m + => MVector (PrimState m) a + -> m Int +length (MVector v) = + readMutVar v + >>= \(MVectorData sz _) -> return sz +{-# INLINABLE length #-} + +-- | Number of elements that the vector currently has reserved space for. +capacity :: (PrimMonad m, V.Unbox a) + => MVector (PrimState m) a + -> m Int +capacity (MVector v) = + readMutVar v + >>= \(MVectorData _ d) -> return $ MV.length d +{-# INLINABLE capacity #-} + +-- | Create a vector with a given capacity. +new :: (PrimMonad m, V.Unbox a) + => Int -- ^ Capacity, must be positive + -> m (MVector (PrimState m) a) +new i = + MV.new i + >>= + \v -> MVector <$> newMutVar (MVectorData 0 v) +{-# INLINABLE new #-} + +-- | Read by index. Performs bounds checking. +read :: (PrimMonad m, V.Unbox a) + => MVector (PrimState m) a + -> Int + -> m a +read (MVector v') i = + readMutVar v' + >>= + \(MVectorData s v) -> + if i >= s || i < 0 + then + error "Data.Vector.Mutable.Dynamic: read: index out of bounds" + else + MV.unsafeRead v i +{-# INLINABLE read #-} + +-- | Read by index without bounds checking. +unsafeRead :: (PrimMonad m, V.Unbox a) + => MVector (PrimState m) a + -> Int + -> m a +unsafeRead (MVector v) i = + readMutVar v + >>= + \(MVectorData _ d) -> d `MV.unsafeRead` i +{-# INLINABLE unsafeRead #-} + +-- | Clear the vector, set length to 0. +-- +-- Does not reallocate, capacity is unchanged. +clear :: PrimMonad m + => MVector (PrimState m) a + -> m () +clear (MVector v) = + readMutVar v + >>= + \(MVectorData _ d) -> writeMutVar v (MVectorData 0 d) +{-# INLINABLE clear #-} + +-- | Increment the size of the vector and write a value to the back. +pushBack :: (PrimMonad m, V.Unbox a) + => MVector (PrimState m) a + -> a + -> m () +pushBack (MVector v) a = + readMutVar v + >>= + \(MVectorData s v') -> + if s == MV.length v' + then do + -- nearly double size each time. + v'' <- MV.unsafeGrow v' (s + 1) + MV.unsafeWrite v'' s a + writeMutVar v (MVectorData (s + 1) v'') + else do + MV.unsafeWrite v' s a + writeMutVar v (MVectorData (s + 1) v') +{-# INLINABLE pushBack #-} diff --git a/src/Imj/Example/DeltaRender/FromMonadIO.hs b/src/Imj/Example/DeltaRender/FromMonadIO.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Example/DeltaRender/FromMonadIO.hs @@ -0,0 +1,23 @@ +{-# OPTIONS_HADDOCK hide #-} + +-- | This example is related to "Imj.Graphics.Render.Delta" : /from a 'MonadIO'/ + +module Imj.Example.DeltaRender.FromMonadIO + ( main + ) where + +import Control.Monad.IO.Class(MonadIO) + +import Imj.Graphics.Color +import Imj.Graphics.Class.Draw(drawStr') +import Imj.Graphics.Class.Render(renderToScreen') +import Imj.Graphics.Render.Delta + +helloWorld :: (MonadIO m) => DeltaEnv -> m () +helloWorld env = do + drawStr' env "Hello World" (Coords 10 10) (onBlack green) + renderToScreen' env + + +main :: IO () +main = runThenRestoreConsoleSettings $ newDefaultEnv >>= helloWorld diff --git a/src/Imj/Example/DeltaRender/FromMonadReader.hs b/src/Imj/Example/DeltaRender/FromMonadReader.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Example/DeltaRender/FromMonadReader.hs @@ -0,0 +1,22 @@ +{-# OPTIONS_HADDOCK hide #-} + +-- | This example is related to "Imj.Graphics.Render.Delta" : +-- /from a 'MonadIO', 'MonadReader' 'DeltaEnv' monad/ + +module Imj.Example.DeltaRender.FromMonadReader + ( main + ) where + +import Control.Monad.Reader(runReaderT) + +import Imj.Graphics.Color +import Imj.Graphics.Render.FromMonadReader(drawStr, renderToScreen) +import Imj.Graphics.Render.Delta + +helloWorld :: (Render e, MonadReader e m, MonadIO m) => m () +helloWorld = do + drawStr "Hello World" (Coords 10 10) (onBlack green) + renderToScreen + +main :: IO () +main = runThenRestoreConsoleSettings $ newDefaultEnv >>= runReaderT helloWorld diff --git a/src/Imj/Example/SequentialTextTranslationsAnchored.hs b/src/Imj/Example/SequentialTextTranslationsAnchored.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Example/SequentialTextTranslationsAnchored.hs @@ -0,0 +1,258 @@ +{-# OPTIONS_HADDOCK hide #-} + +{-# LANGUAGE OverloadedStrings #-} + +{- | Examples of animated text. + +Run @imj-base-examples-exe@ to see these examples displayed in the terminal, +in a grid. + +Grid lines correspond to different examples, and grid columns are : + +* left : using "AnchorChars" +* right: using "StringChars" + +-} + +module Imj.Example.SequentialTextTranslationsAnchored + ( exampleOfsequentialTextTranslationsAnchored + -- * Reexports + , module Imj.Graphics.Text.Animation + ) where + +import Data.Monoid((<>)) +import Data.Text(pack) +import Control.Concurrent(threadDelay) +import Control.Monad.IO.Class(MonadIO, liftIO) +import Control.Monad.Reader.Class(MonadReader) + +import Imj.Geo.Discrete +import Imj.Graphics.Class.Render +import Imj.Graphics.Color +import Imj.Graphics.Render.FromMonadReader +import Imj.Graphics.Text.Alignment +import Imj.Graphics.Text.Animation +import Imj.Graphics.Text.ColorString +import Imj.Graphics.UI.RectContainer + + +-- | Shows the differences between 'AnchorChars' and 'AnchorStrings', by comparing, +-- with the same inputs: +-- +-- * 'mkSequentialTextTranslationsCharAnchored' / 'renderAnimatedTextCharAnchored' +-- * 'mkSequentialTextTranslationsStringAnchored' / 'renderAnimatedTextStringAnchored' +exampleOfsequentialTextTranslationsAnchored :: (Render e, MonadReader e m, MonadIO m) + => m () +exampleOfsequentialTextTranslationsAnchored = do + let (Examples es') = allExamples + es = accumHeights es' 0 + animate es + +accumHeights :: [Example] -> Length Height -> [Example] +accumHeights [] _ = [] +accumHeights ((Example a h _ b c):es) acc = + (Example a h acc b c):accumHeights es (acc + h) + +width :: Length Width +width = 30 + +upperLeft :: Coords Pos +upperLeft = Coords 4 50 + +data Examples = Examples [Example] + +data Example = Example { + _exampleInputData :: ![([ColorString], Coords Pos, Coords Pos)] + , _exampleSelfHeight :: !(Length Height) + , _exampleStartHeight :: !(Length Height) + , _exampleName :: !String + , _exampleComment :: !String +} + +runExampleCharAnchored :: (Render e, MonadReader e m, MonadIO m) + => [([ColorString], Coords Pos, Coords Pos)] + -> Coords Pos + -> (Frame, (Frame -> m ())) +runExampleCharAnchored input ref = + let anim@(TextAnimation _ _ (EaseClock (Evolution _ lastFrame _ _))) = + mkSequentialTextTranslationsCharAnchored (translateInput ref input) 1 + in (lastFrame, (renderAnimatedTextCharAnchored anim)) + +runExampleStringAnchored :: (Render e, MonadReader e m, MonadIO m) + => [([ColorString], Coords Pos, Coords Pos)] + -> Coords Pos + -> (Frame, (Frame -> m ())) +runExampleStringAnchored input ref = + let anim@(TextAnimation _ _ (EaseClock (Evolution _ lastFrame _ _))) = + mkSequentialTextTranslationsStringAnchored (translateInput ref input) 1 + in (lastFrame, (renderAnimatedTextStringAnchored anim)) + +translateInput :: Coords Pos + -> [([ColorString], Coords Pos, Coords Pos)] + -> [([ColorString], Coords Pos, Coords Pos)] +translateInput tr input = + map (\(l, c1, c2) -> (l, translate tr c1, translate tr c2)) input + +allExamples :: Examples +allExamples = + Examples + [ Example exampleDownTranslationDuo 7 0 + "DownTranslationDuo" + "Char and String anchors give different results because there is a move" + , Example exampleDownTranslationMono 7 0 + "DownTranslationMono" + "Char and String anchors give different results because there is a move" + , Example exampleIntermediateCharAdditions 6 0 + "IntermediateCharAdditions" + "When the chars are inserted in the middle, their color is a gradual interpolation between neighbour colors." + , Example exampleIntermediateCharRemovals 6 0 + "IntermediateCharRemovals" + "" + , Example exampleExtremeCharAdditions 6 0 + "ExtremeCharAdditions" + "When the chars are inserted at an extremity, they match the neighbour color." + , Example exampleExtremeCharRemovals 6 0 + "ExtremeCharRemovals" + "" + ] + +-- | shows an example with multiple strings : global color is changed in parallel +-- but anchors are changed sequentially +exampleDownTranslationDuo :: [([ColorString], Coords Pos, Coords Pos)] +exampleDownTranslationDuo = + let a = colored "ABC" green <> colored "DEF" (rgb 2 2 2) + b = colored "ABC" white <> colored "DEF" yellow + txt1 = [a, b] + from1 = Coords 0 0 + to1 = Coords 1 0 + from2 = Coords 0 10 + to2 = Coords 1 10 + in [(txt1, from1, to1) + , (txt1, from2, to2)] + +exampleDownTranslationMono :: [([ColorString], Coords Pos, Coords Pos)] +exampleDownTranslationMono = + let a = colored "ABC" green <> colored "DEF" (rgb 2 2 2) + b = colored "ABC" white <> colored "DEF" yellow + txt1 = [a, b] + from1 = Coords 0 0 + to1 = Coords 1 0 + in [(txt1, from1, to1)] + + +exampleIntermediateCharAdditions :: [([ColorString], Coords Pos, Coords Pos)] +exampleIntermediateCharAdditions = + let a = colored "A" green <> colored "O" white + b = colored "ABCDEFGHIJKLMNO" white + txt1 = [a, b] + from1 = Coords 0 0 + to1 = Coords 0 0 + in [(txt1, from1, to1)] + +exampleIntermediateCharRemovals :: [([ColorString], Coords Pos, Coords Pos)] +exampleIntermediateCharRemovals = + let a = colored "ABCDEFGHIJKLMNO" white + b = colored "A" green <> colored "O" white + txt1 = [a, b] + from1 = Coords 0 0 + to1 = Coords 0 0 + in [(txt1, from1, to1)] + +exampleExtremeCharAdditions :: [([ColorString], Coords Pos, Coords Pos)] +exampleExtremeCharAdditions = + let a = colored "ABC" green + b = colored "ABC" green <> colored "DEF" white + txt1 = [a, b] + from1 = Coords 0 0 + to1 = Coords 0 0 + in [(txt1, from1, to1)] + + +exampleExtremeCharRemovals :: [([ColorString], Coords Pos, Coords Pos)] +exampleExtremeCharRemovals = + let a = colored "ABC" green <> colored "DEF" white + b = colored "ABC" green + txt1 = [a, b] + from1 = Coords 0 0 + to1 = Coords 0 0 + in [(txt1, from1, to1)] + +animate :: (Render e, MonadReader e m, MonadIO m) + => [Example] + -> m () +animate examples = do + let listActions = concatMap (\ex@(Example e _ startHeight _ _) -> + let (a,b) = runExampleCharAnchored e ref + (c,d) = runExampleStringAnchored e (move (fromIntegral width) RIGHT ref) + ref = getRef startHeight + in [(a,b,ex,0),(c,d,ex,1)]) examples + frames = replicate (length listActions) (Frame 0) + colTitles = ["Char anchored", "String anchored"] + animate' listActions examples frames colTitles + +getRef :: Length Height -> Coords Pos +getRef startHeight = + translate upperLeft $ Coords (fromIntegral startHeight) 0 + +animate' :: (Render e, MonadReader e m, MonadIO m) + => [(Frame, (Frame -> m ()), Example, Int)] + -> [Example] + -> [Frame] + -> [String] + -> m () +animate' listActions examples frames colTitles = do + let newFrames = zipWith (\count (lastFrame, _, _, _) -> + if count >= lastFrame + then Frame 0 + else succ count) frames listActions + drawActions listActions frames + drawExamples examples + drawColTitles colTitles + renderToScreen + liftIO $ threadDelay 1000000 + animate' listActions examples newFrames colTitles + +myDarkGray :: LayeredColor +myDarkGray = onBlack $ gray 6 +myLightGray :: LayeredColor +myLightGray = onBlack $ gray 10 + +drawActions :: (Render e, MonadReader e m, MonadIO m) + => [(Frame, (Frame -> m ()), Example, Int)] + -> [Frame] + -> m () +drawActions listActions frames = + mapM_ (\(frame, (lastFrame, action, (Example _ height startHeight _ _), wIdx)) -> do + let r = RectContainer (Size (height-2) (width-3)) (translate (Coords (-2) (-2)) ref) + ref = move (wIdx * fromIntegral width) RIGHT (getRef startHeight) + drawUsingColor r myDarkGray + action frame + drawColorStr (progress frame lastFrame) (translate ref $ Coords (fromIntegral height - 4) 0) + ) $ zip frames listActions + +drawExamples :: (Render e, MonadReader e m, MonadIO m) + => [Example] + -> m () +drawExamples examples = + mapM_ (\(Example _ height startHeight leftTitle rightComment) -> do + let down = (quot (fromIntegral height) 2) + fromIntegral startHeight - 2 + at = translate upperLeft (Coords down (-8)) + at' = translate upperLeft (Coords down $ 2 * (fromIntegral width)) + drawAlignedTxt_ (pack leftTitle) myDarkGray (mkRightAlign at) + drawStr rightComment at' myDarkGray + ) examples + +drawColTitles :: (Render e, MonadReader e m, MonadIO m) + => [String] + -> m () +drawColTitles l = + mapM_ (\(i,colTitle) -> do + let right = quot (fromIntegral width) 2 + fromIntegral (i*width) - 3 + at = translate upperLeft (Coords (-3) right) + drawAlignedTxt_ (pack colTitle) myDarkGray (mkCentered at) + ) $ zip [0..] l + +progress :: Frame -> Frame -> ColorString +progress (Frame cur) (Frame total) = + let points = replicate cur '-' ++ replicate (total - cur) ' ' + in colored' "[" myLightGray <> colored' (pack points) myDarkGray <> colored' "]" myLightGray diff --git a/src/Imj/GameItem/Weapon/Laser.hs b/src/Imj/GameItem/Weapon/Laser.hs new file mode 100644 --- /dev/null +++ b/src/Imj/GameItem/Weapon/Laser.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE LambdaCase #-} + +module Imj.GameItem.Weapon.Laser + ( -- * Laser representations + {- | 'LaserRay' and 'Ray' are parametrized by phantom types + 'Theoretical' and 'Actual' to indicate if the ray was computed taking + obstacles into account or not: + -} + LaserRay(..) + , Ray(..) + , Theoretical + , Actual + -- ** Laser reach + , LaserReach(..) + -- ** Create a Theoretical Ray + -- | 'shootLaser' and 'shootLaserWithOffset' create a 'Theoretical' ray, i.e it doesn't + -- stop at obstacles: + , shootLaser + , shootLaserWithOffset + -- ** Create an Actual Ray + -- | 'computeActualLaserShot' converts a 'Theoretical' ray to an 'Actual' ray, i.e + -- it stops at obstacles (or not), according to 'LaserPolicy': + , LaserPolicy(..) + , computeActualLaserShot + -- * Utilities + , afterEnd + ) where + +import Imj.Prelude + +import Data.List( minimumBy, partition ) +import Data.Maybe( isJust, isNothing ) + +import Imj.GameItem.Weapon.Laser.Types +import Imj.Geo.Discrete +import Imj.Physics.Discrete.Collision + + +-- | Same as 'shootLaser' but offsets the start 'Coords' by one in the shot 'Direction'. +shootLaserWithOffset :: Coords Pos + -- ^ Start coordinates + -> Direction + -- ^ Direction of the shot + -> LaserReach + -> (Coords Pos -> Location) + -- ^ Collision function + -> Maybe (Ray Theoretical) +shootLaserWithOffset shipCoords dir = + shootLaser (translateInDir dir shipCoords) dir + +-- | Creates a 'Ray' by extending from a 'Coords' until a collision is found. +shootLaser :: Coords Pos + -> Direction + -> LaserReach + -> (Coords Pos -> Location) + -> Maybe (Ray Theoretical) +shootLaser laserStart dir laserType getLocation = + case getLocation laserStart of + OutsideWorld -> Nothing + InsideWorld -> + case laserType of + Infinite -> + let continueExtension c = getLocation c == InsideWorld + seg = mkSegmentByExtendingWhile laserStart dir continueExtension + in Just $ Ray seg + + +stopRayAtFirstCollision :: [Coords Pos] -> Ray Theoretical -> (Ray Actual, Maybe (Coords Pos)) +stopRayAtFirstCollision coords (Ray s) = + let collisions = + map (\(c, Just i) -> (c,i)) + $ filter (\(_, i) -> isJust i) + $ zip coords + $ map (`segmentContains` s) coords + limitAtFirstCollision :: [(Coords Pos, Int)] -> Segment -> (Ray Actual, Maybe (Coords Pos)) + limitAtFirstCollision collis seg = case collis of + [] -> (Ray seg, Nothing) + l -> (Ray (changeSegmentLength (snd minElt) seg), Just $ fst minElt) + where + minElt = minimumBy (\(_, i) (_, j) -> compare (abs i) (abs j)) l + in limitAtFirstCollision collisions s + +-- | Returns the 'Coords' that is just after the end of the 'LaserRay' +afterEnd :: LaserRay Actual -> Coords Pos +afterEnd (LaserRay dir (Ray seg)) = + translateInDir dir $ snd $ extremities seg + +-- | Converts a 'Theoretical' laser ray to an 'Actual' one, +-- taking obstacles and a 'LaserPolicy' into account. +-- +-- Returns a partition of obstacles between the remaining and the destroyed ones. +computeActualLaserShot :: [a] + -- ^ Obstacles. + -> (a -> Coords Pos) + -- ^ Obstacle to 'Coords' function. + -> LaserRay Theoretical + -- ^ The 'LaserRay' that doesn't take obstacles into account. + -> LaserPolicy + -> (([a],[a]), Maybe (LaserRay Actual)) +computeActualLaserShot obstacles coords (LaserRay dir theoreticalRay@(Ray seg)) = \case + DestroyAllObstacles -> + ( partition (\e -> isNothing $ segmentContains (coords e) seg) obstacles + , Just $ LaserRay dir $ Ray seg) + DestroyFirstObstacle -> + let (rayActual, mayCoord) = + stopRayAtFirstCollision (map coords obstacles) theoreticalRay + remainingObstacles = case mayCoord of + Nothing -> (obstacles,[]) + (Just pos') -> partition (\e -> coords e /= pos') obstacles + in ( remainingObstacles + , Just $ LaserRay dir rayActual) diff --git a/src/Imj/GameItem/Weapon/Laser/Types.hs b/src/Imj/GameItem/Weapon/Laser/Types.hs new file mode 100644 --- /dev/null +++ b/src/Imj/GameItem/Weapon/Laser/Types.hs @@ -0,0 +1,41 @@ +{-# OPTIONS_HADDOCK hide #-} + +{-# LANGUAGE NoImplicitPrelude #-} + +module Imj.GameItem.Weapon.Laser.Types + ( LaserRay(..) + , Ray(..) + , Theoretical + , Actual + , LaserPolicy(..) + , LaserReach(..) + ) where + + +import Imj.Geo.Discrete.Types + +-- | A laser ray and the direction in which the laser was shot. +data LaserRay a = LaserRay { + _laserRayDir :: !Direction + -- ^ The direction in which the laser was shot + , _laserRaySeg :: !(Ray a) + -- ^ The laser trajectory. +} + +-- | A Laser ray +newtype Ray a = Ray Segment + +-- | The laser ray was computed ignoring obstacles +data Theoretical + +-- | The laser ray was computed taking obstacles into account. +data Actual + +-- | Tells which obstacles are destroyed on the 'Segment' of 'Ray' 'Theoretical' +data LaserPolicy = DestroyFirstObstacle + -- ^ The first obstacle is destroyed. + | DestroyAllObstacles + -- ^ All obstacles are destroyed. + +-- | The reach of the laser. +data LaserReach = Infinite diff --git a/src/Imj/Geo/Continuous.hs b/src/Imj/Geo/Continuous.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Geo/Continuous.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Imj.Geo.Continuous + (-- * Continuous coordinates + Vec2(..) + , module Imj.Geo.Continuous.Conversion + -- * Sampled continuous geometry + -- ** Circle + , translatedFullCircle + , translatedFullCircleFromQuarterArc + -- ** Parabola + , parabola + -- * Polygon extremities + , polyExtremities + -- * Vec2 utilities + , sumVec2d + , scalarProd + , rotateByQuarters + -- * Reexports + , Pos, Vel, Acc + ) where + +import Imj.Prelude + +import Imj.Geo.Continuous.Types +import Imj.Geo.Continuous.Conversion +import Imj.Iteration + +-- | Creates a list of 4 'Vec2' from a single one by rotating it successively by pi/2. +rotateByQuarters :: Vec2 Pos -> [Vec2 Pos] +rotateByQuarters v@(Vec2 x y) = + [v, + Vec2 x $ -y, + Vec2 (-x) $ -y, + Vec2 (-x) y] + +-- | Sums two 'Vec2'. +{-# INLINE sumVec2d #-} +sumVec2d :: Vec2 a -> Vec2 a -> Vec2 a +sumVec2d (Vec2 vx vy) (Vec2 wx wy) = Vec2 (vx+wx) (vy+wy) + +-- | Multiplies a 'Vec2' by a scalar. +scalarProd :: Float -> Vec2 a -> Vec2 a +scalarProd f (Vec2 x y) = Vec2 (f*x) (f*y) + +-- | Integrate twice a constant acceleration over a duration, return a position +{-# INLINE integrateAcceleration2 #-} +integrateAcceleration2 :: Frame -> Vec2 Acc -> Vec2 Pos +integrateAcceleration2 (Frame time) (Vec2 vx vy) = + let factor = 0.5 * fromIntegral (time * time) + in Vec2 (vx * factor) (vy * factor) + +-- | Integrate a constant velocity over a duration, return a position +{-# INLINE integrateVelocity #-} +integrateVelocity :: Frame -> Vec2 Vel -> Vec2 Pos +integrateVelocity (Frame time) (Vec2 vx vy) = + let factor = fromIntegral time + in Vec2 (vx * factor) (vy * factor) + +gravity :: Vec2 Acc +gravity = Vec2 0 0.032 -- this number was adjusted so that the timing in Hamazed + -- game looks good. Instead, we could have adjusted the scale + -- of the world. + +{-| Using +: + +\[ \vec r = \vec r_0 + \vec v_0*t + {1 \over 2}* \vec a*t^2 \] + +\[ where \] + +\[ \vec r = current\;position \] + +\[ \vec r_0 = initial\;position \] + +\[ \vec v_0 = initial\;velocity \] + +\[ \vec a = gravity\;force \] + +\[ t = time \] + +-} +parabola :: Vec2 Pos -> Vec2 Vel -> Frame -> Vec2 Pos +parabola r0 v0 time = + let iv = integrateVelocity time v0 + ia = integrateAcceleration2 time gravity + in sumVec2d r0 $ sumVec2d iv ia + +mkPointOnCircle :: Float -> Float -> Vec2 Pos +mkPointOnCircle radius angle = + let x = radius * sin angle + y = radius * cos angle + in Vec2 x y + +discretizeArcOfCircle :: Float -> Float -> Float -> Int -> [Vec2 Pos] +discretizeArcOfCircle radius arcAngle firstAngle resolution = + let angleIncrement = arcAngle / (fromIntegral resolution :: Float) + in map (\i -> + let angle = firstAngle + angleIncrement * (fromIntegral i :: Float) + in mkPointOnCircle radius angle) [0..resolution] + +fullCircleFromQuarterArc :: Float -> Float -> Int -> [Vec2 Pos] +fullCircleFromQuarterArc radius firstAngle quarterArcResolution = + let quarterArcAngle = pi/2 + quarterCircle = discretizeArcOfCircle radius quarterArcAngle firstAngle quarterArcResolution + in concatMap rotateByQuarters quarterCircle + +fullCircle :: Float -> Float -> Int -> [Vec2 Pos] +fullCircle radius firstAngle resolution = + let totalAngle = 2*pi + in discretizeArcOfCircle radius totalAngle firstAngle resolution + +-- | Samples a circle in an optimized way, to reduce the number of 'sin' and 'cos' +-- calls. +-- +-- The total number of points will always be a multiple of 4. +translatedFullCircleFromQuarterArc :: Vec2 Pos + -- ^ Center + -> Float + -- ^ Radius + -> Float + -- ^ The angle corresponding to the first sampled point + -> Int + -- ^ The total number of sampled points __per quarter arc__. + -> [Vec2 Pos] +translatedFullCircleFromQuarterArc center radius firstAngle resolution = + let circle = fullCircleFromQuarterArc radius firstAngle resolution + in map (sumVec2d center) circle + +-- | Samples a circle. +translatedFullCircle :: Vec2 Pos + -- ^ Center + -> Float + -- ^ Radius + -> Float + -- ^ The angle corresponding to the first sampled point + -> Int + -- ^ The total number of sampled points + -> [Vec2 Pos] +translatedFullCircle center radius firstAngle resolution = + let circle = fullCircle radius firstAngle resolution + in map (sumVec2d center) circle + +-- | Returns the extremities of a polygon. Note that it is equal to 'translatedFullCircle' +polyExtremities :: Vec2 Pos + -- ^ Center + -> Float + -- ^ Radius + -> Float + -- ^ Rotation angle + -> Int + -- ^ Number of sides of the polygon. + -> [Vec2 Pos] +polyExtremities = translatedFullCircle diff --git a/src/Imj/Geo/Continuous/Conversion.hs b/src/Imj/Geo/Continuous/Conversion.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Geo/Continuous/Conversion.hs @@ -0,0 +1,47 @@ +{-# OPTIONS_HADDOCK hide #-} + +{-# LANGUAGE NoImplicitPrelude #-} + + +module Imj.Geo.Continuous.Conversion + ( -- * Conversion to / from discrete coordinates +{- | Discrete positions are converted to continuous positions by +placing them at the "pixel center", ie by applying an offset of (0.5, 0.5) in +'pos2vec'. + +Then, during the inverse transformation - in 'vec2pos', coordinates are just +floored. + +Discrete speeds are converted with 'speed2vec'. The half-pixel convention is not +applied for speeds. The inverse conversion is 'vec2speed'. +-} + pos2vec + , vec2pos + , speed2vec + , vec2speed + ) where + +import Imj.Prelude + +import Imj.Geo.Continuous.Types +import Imj.Geo.Discrete.Types + +-- | Convert a discrete position to a continuous position. +pos2vec :: Coords Pos -> Vec2 Pos +pos2vec (Coords r c) = + Vec2 (0.5 + fromIntegral c) (0.5 + fromIntegral r) + +-- | Convert a continuous position to a discrete position. +vec2pos :: Vec2 Pos -> Coords Pos +vec2pos (Vec2 x y) = + Coords (floor y) (floor x) + +-- | Convert a discrete speed to a continuous speed. +speed2vec :: Coords Vel -> Vec2 Vel +speed2vec (Coords r c) = + Vec2 (fromIntegral c) (fromIntegral r) + +-- | Convert a continuous speed to a discrete speed. +vec2speed :: Vec2 Vel -> Coords Vel +vec2speed (Vec2 x y) = + Coords (fromIntegral (round y :: Int)) (fromIntegral (round x :: Int)) diff --git a/src/Imj/Geo/Continuous/Types.hs b/src/Imj/Geo/Continuous/Types.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Geo/Continuous/Types.hs @@ -0,0 +1,20 @@ +{-# OPTIONS_HADDOCK hide #-} + +{-# LANGUAGE NoImplicitPrelude #-} + +module Imj.Geo.Continuous.Types + ( Vec2(..) + -- Reexports + , Pos, Vel, Acc + ) where + +import Imj.Prelude + +import Imj.Geo.Types + +-- | Continuous 2d coordinates. We use phantom types 'Pos', 'Vel', 'Acc' to +-- distinguish between a position, a velocity, and an acceleration. +data Vec2 a = Vec2 { + _vec2X :: {-# UNPACK #-} !Float + , _vec2Y :: {-# UNPACK #-} !Float +} deriving(Eq, Show, Ord) diff --git a/src/Imj/Geo/Discrete.hs b/src/Imj/Geo/Discrete.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Geo/Discrete.hs @@ -0,0 +1,187 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Imj.Geo.Discrete + ( module Imj.Geo.Discrete.Types + -- * Construct Segment + , mkSegmentByExtendingWhile + , changeSegmentLength + -- * Use Segment + , extremities + , segmentContains + -- * Construct Coords + , zeroCoords + , coordsForDirection + -- * Use Coords + , diffCoords + , diffPosToSpeed + , sumCoords + , sumPosSpeed + , move + , translate + , translate' + , translateInDir + -- * Discrete algorithms + -- ** Bresenham + {- | The 2d version, 'bresenham', allows to + . + + The 3d version, 'bresenham3', allows to interpolate discrete colors in RGB space. + -} + , module Imj.Geo.Discrete.Bresenham + , module Imj.Geo.Discrete.Bresenham3 + -- ** List resampling + {- | Typically, 'resampleWithExtremities' will be used on the result of 'bresenham' + to over-sample the produced line. + -} + , module Imj.Geo.Discrete.Resample + ) where + +import Imj.Prelude + +import Imj.Geo.Discrete.Types +import Imj.Geo.Discrete.Bresenham +import Imj.Geo.Discrete.Bresenham3 +import Imj.Geo.Discrete.Resample + +-- | 'zeroCoords' = 'Coords' 0 0 +zeroCoords :: Coords a +zeroCoords = Coords 0 0 + +-- | Returns a - b +diffCoords :: Coords a + -- ^ a + -> Coords a + -- ^ b + -> Coords a + -- ^ a - b +diffCoords (Coords r1 c1) (Coords r2 c2) = + Coords (r1 - r2) (c1 - c2) + +-- | Returns a + b +sumCoords :: Coords a + -- ^ a + -> Coords a + -- ^ b + -> Coords a + -- ^ a + b +sumCoords (Coords r1 c1) (Coords r2 c2) = + Coords (r1 + r2) (c1 + c2) + +-- | Assumes that we integrate over one game step. +-- +-- Returns a + b +sumPosSpeed :: Coords Pos + -> Coords Vel + -> Coords Pos +sumPosSpeed (Coords r1 c1) (Coords r2 c2) = + Coords (r1 + r2) (c1 + c2) + +{-# INLINE diffPosToSpeed #-} +diffPosToSpeed :: Coords Pos + -> Coords Pos + -> Coords Vel +diffPosToSpeed (Coords r1 c1) (Coords r2 c2) = + Coords (r1 - r2) (c1 - c2) + +-- | Returns the coordinates that correspond to one step in the given direction. +coordsForDirection :: Direction -> Coords a +coordsForDirection Down = Coords 1 0 +coordsForDirection Up = Coords (-1) 0 +coordsForDirection LEFT = Coords 0 (-1) +coordsForDirection RIGHT = Coords 0 1 + +multiply :: Int -> Coords a -> Coords a +multiply n (Coords r c) = Coords (r * fromIntegral n) (c * fromIntegral n) + +-- | Translate of 1 step in a given direction. +translateInDir :: Direction -> Coords a -> Coords a +translateInDir dir = translate $ coordsForDirection dir + + +-- | Modify the end of the segment to reach the given length +changeSegmentLength :: Int -> Segment -> Segment +changeSegmentLength i (Horizontal row c1 _) = Horizontal row c1 $ c1 + fromIntegral i +changeSegmentLength i (Vertical col r1 _) = Vertical col r1 $ r1 + fromIntegral i +changeSegmentLength _ _ = error "changeSegmentLength cannot operate on oblique segments" -- TODO use bresenham if it is valid + +-- | Returns the distance from segment start +segmentContains :: Coords Pos + -- ^ The coordinates to test + -> Segment + -> Maybe Int + -- ^ 'Nothing' if the coordinate is not contained, else 'Just' + -- the distance from segment start. +segmentContains (Coords row' c) (Horizontal row c1 c2) = + if row' == row + then + fromIntegral <$> rangeContains c1 c2 c + else + Nothing +segmentContains (Coords r col') (Vertical col r1 r2) = + if col' == col + then + fromIntegral <$> rangeContains r1 r2 r + else + Nothing +segmentContains _ _ = + error "segmentContains cannot operate on oblique segments" -- TODO use bresenham + +-- | Returns the start and end coordinates. +extremities :: Segment -> (Coords Pos, Coords Pos) +extremities (Horizontal row c1 c2) = (Coords row c1, Coords row c2) +extremities (Vertical col r1 r2) = (Coords r1 col, Coords r2 col) +extremities (Oblique c1 c2) = (c1, c2) + +-- returns Just (value - range start) if it is contained +{-# INLINABLE rangeContains #-} +rangeContains :: (Num a, Eq a) => a -> a -> a -> Maybe a +rangeContains r1 r2 i = + if abs (r2-i) + abs (i-r1) == abs (r2-r1) + then + Just (i - r1) + else + Nothing + +-- | 'translate' = 'sumCoords' +translate :: Coords a -> Coords a -> Coords a +translate = sumCoords + +-- | Translate by a given height and width. +translate' :: Length Height + -- ^ The height to add + -> Length Width + -- ^ The width to add + -> Coords Pos + -- The initial coordinates + -> Coords Pos +translate' h w c = + sumCoords c $ toCoords h w + +move :: Int + -- ^ Take that many steps + -> Direction + -- ^ In that direction + -> Coords a + -- ^ From these coordinates + -> Coords a +move t dir c = sumCoords c $ multiply t $ coordsForDirection dir + +mkSegmentByExtendingWhile :: Coords Pos + -- ^ start of the segment + -> Direction + -- ^ 'Direction' in which to extend + -> (Coords Pos -> Bool) + -- ^ Continue extension while this functions returns 'True'. + -> Segment +mkSegmentByExtendingWhile start dir f = + let end = extend' start dir f + in mkSegment start end + +extend' :: Coords Pos -> Direction -> (Coords Pos -> Bool) -> Coords Pos +extend' coords dir continue = + let loc = translateInDir dir coords + in if continue loc + then + extend' loc dir continue + else + coords diff --git a/src/Imj/Geo/Discrete/Bresenham.hs b/src/Imj/Geo/Discrete/Bresenham.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Geo/Discrete/Bresenham.hs @@ -0,0 +1,28 @@ +{-# OPTIONS_HADDOCK hide #-} + +{-# LANGUAGE NoImplicitPrelude #-} + +module Imj.Geo.Discrete.Bresenham + ( bla + ) where + +import Imj.Prelude + + +-- adapted from http://www.roguebasin.com/index.php?title=Bresenham%27s_Line_Algorithm#Haskell +balancedWord :: Int -> Int -> Int -> [Int] +balancedWord p q eps + | eps + p < q = 0 : balancedWord p q (eps + p) + | otherwise = 1 : balancedWord p q (eps + p - q) + +-- | Bresenham's line algorithm. +-- Includes the first point and goes through the second to infinity. +bla :: (Int, Int) -> (Int, Int) -> [(Int, Int)] +bla (x0, y0) (x1, y1) = + let (dx, dy) = (x1 - x0, y1 - y0) + xyStep b (x, y) = (x + signum dx, y + signum dy * b) + yxStep b (x, y) = (x + signum dx * b, y + signum dy) + (p, q, step) | abs dx > abs dy = (abs dy, abs dx, xyStep) + | otherwise = (abs dx, abs dy, yxStep) + walk w xy = xy : walk (tail w) (step (head w) xy) + in walk (balancedWord p q 0) (x0, y0) diff --git a/src/Imj/Geo/Discrete/Bresenham3.hs b/src/Imj/Geo/Discrete/Bresenham3.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Geo/Discrete/Bresenham3.hs @@ -0,0 +1,50 @@ +{-# OPTIONS_HADDOCK hide #-} + +{-# LANGUAGE NoImplicitPrelude #-} + +module Imj.Geo.Discrete.Bresenham3 + ( bresenham3Length + , bresenham3 + ) where + +import Imj.Prelude + +import Data.List( zip3 ) + + +-- | Source: https://www.reddit.com/r/haskell/comments/14h4az/3d_functional_bresenham_algorithm/ +-- +-- slightly modified to fix a bug when rise1 == rise2, rise1 > run and rise2 > run +bres :: Int -> Int -> Int -> [(Int, Int, Int)] +bres run rise1 rise2 + | run < 0 = [(-x, y, z) | (x, y, z) <- bres (-run) rise1 rise2] + | rise1 < 0 = [( x, -y, z) | (x, y, z) <- bres run (-rise1) rise2] + | rise2 < 0 = [( x, y, -z) | (x, y, z) <- bres run rise1 (-rise2)] + | rise1 > max run rise2 = + [( x, y, z) | (y, x, z) <- bres rise1 run rise2] + | rise2 > max run rise1 = + [( x, y, z) | (z, x, y) <- bres rise2 run rise1] + | run < rise1 = + [( x, y, z) | (y, x, z) <- bres rise1 run (assert (rise1 == rise2) rise2)] + | otherwise = zip3 [0..run] + (map fst $ iterate (step rise1) (0, run `div` 2)) + (map fst $ iterate (step rise2) (0, run `div` 2)) + where + step rise (y, err) + | err' < 0 = (y + 1, err' + run) + | otherwise = (y, err') + where err' = err - rise + +-- | 3D version of the bresenham algorithm. +{-# INLINABLE bresenham3 #-} +bresenham3 :: (Int, Int, Int) -> (Int, Int, Int) -> [(Int, Int, Int)] +bresenham3 (x1, y1, z1) (x2, y2, z2) = + [(x1+x, y1+y, z1+z) | (x, y, z) <- bres (x2-x1) (y2-y1) (z2-z1)] + + +-- | Returns the 3D bresenham length between two 3D coordinates. +{-# INLINABLE bresenham3Length #-} +-- avoid using unsigned types, as it complicates the calculations +bresenham3Length :: (Int, Int, Int) -> (Int, Int, Int) -> Int +bresenham3Length (x1, y1, z1) (x2, y2, z2) + = succ $ max (abs (x1-x2)) $ max (abs (y1-y2)) (abs (z1-z2)) diff --git a/src/Imj/Geo/Discrete/Resample.hs b/src/Imj/Geo/Discrete/Resample.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Geo/Discrete/Resample.hs @@ -0,0 +1,153 @@ +{-# OPTIONS_HADDOCK hide #-} + +{-# LANGUAGE NoImplicitPrelude #-} + + +module Imj.Geo.Discrete.Resample + ( resampleWithExtremities + ) where + +import Imj.Prelude + +import Data.List( length ) + +import Imj.Util( replicateElements ) + + +{- | Resamples a list, using the analogy where a list +is seen as a uniform sampling of a geometrical segment. + +With a uniform sampling strategy, for an input of length \( n \), and a desired +output of length \( m \): + +* /Regular/ samples are repeated \( r = \lfloor {m \over n} \rfloor \) times. +* /Over-represented/ samples are repeated \( r + 1 \) times. + +If \( m' \) is the number of over-represented samples, + +\[ +\begin{alignedat}{2} + m &= r*n + m' \\ +\implies \quad m' &= m - r*n +\end{alignedat} +\] + +We can chose over-represented samples in at least two different ways: + +* __Even spread__ : + + * Given a partition of the input continuous interval \( [\,0, length]\, \) + in \( m' \) equal-length intervals, the over-represented samples are located at + the (floored) centers of these intervals. + + * More precisely, over-represented samples indexes are: + + \[ \biggl\{ a + \Bigl\lfloor {1 \over 2} + { n-1-a \over m-1 } * s \Bigl\rfloor \mid s \in [\,0\,..\,m'-1] \;,\; a = {1 \over 2} * {n \over m'} \biggl\} \] + + * Example : for a length 5 input, and 2 over-represented samples: + + @ + input samples: ----- + + over-represented samples: - - + @ + +* __"Even with extremities" spread__: + + * The first and last over-represented samples match + with an input extremity. The rest of the over-represented samples are positionned + "regularly" in-between the first and last. An exception is made when there is only one + over-represented sample : in that case it is placed in the middle. + + * More precisely, over-represented samples indexes are: + + \[ if \; m' == 1 : \biggl\{ \Bigl\lfloor {n-1 \over 2} \Bigl\rfloor \biggl\} \] + + \[ otherwise : \biggl\{ \Bigl\lfloor {1 \over 2} + {n-1 \over m'-1}*s \Bigl\rfloor \mid s \in [\,0,m'-1]\, \biggl\} \] + + * Example : for a length 5 input, and 2 over-represented samples: + + @ + input samples: ----- + + over-represented samples: - - + @ + + /As its name suggests, this function uses the "even with extremities" spread./ + + /For clarity, the variable names used in the code match the ones in the documentation./ +-} +resampleWithExtremities :: [a] + -- ^ Input + -> Int + -- ^ \( n \) : input length. It is expected that \( 0 <= n <= \) @length input@ + -> Int + -- ^ \( m \) : output length. It is expected that \( 0 <= m \). + -> [a] + -- ^ Output : + -- + -- * when \( m < n \), it is a /downsampled/ version of the input, + -- * when \( m > n \), it is an /upsampled/ version of the input. +resampleWithExtremities input n m + | assert (m >= 0) m == n = input + | otherwise = + let r = quot m n + m' = m - (r * n) + res + | m' == 0 = replicateElements r input + | otherwise = let overRepIdx = getOverRepIdx (assert (m' > 0) m') n 0 + in resampleRec m' n 0 (overRepIdx, 0) input r + in assert (verifyResample input m res) res + + +resampleRec :: Int + -- ^ over-represented samples count + -> Int + -- ^ \( n \) : input length. + -> Int + -- ^ current index + -> (Int, Int) + -- ^ (next overrepresentation index, count of over-represented samples sofar) + -> [a] + -- ^ the list to be resampled + -> Int + -- ^ \( r = floor(m/n) \) : every sample will be replicated + -- \( r \) times, or \( r + 1 \) times if distance to next overrepresentation == 0 + -> [a] +resampleRec _ _ _ _ [] _ = [] +resampleRec m' n curIdx (overRepIdx, s) l@(_:_) r = + let (nCopies, nextState) + -- This commented guard was used to debug cases where the assert on the line after would fail +-- | overIdx < curIdx = error ("\noverIdx " ++ show overIdx ++ "\ncurIdx " ++ show curIdx ++ "\nm' " ++ show m' ++ "\nn " ++ show n ++ "\ns " ++ show s) + | assert (overRepIdx >= curIdx) overRepIdx == curIdx + = let nextS = succ s + nextOverRepIdx = getOverRepIdx m' n nextS + in (succ r, (nextOverRepIdx, nextS)) + | otherwise = (r , (overRepIdx , s)) + in replicate nCopies (head l) ++ resampleRec m' n (succ curIdx) nextState (tail l) r + + +-- | Returns maxBound when there is no over-representation +getOverRepIdx :: Int -> Int -> Int -> Int +getOverRepIdx m' n s + | m' >  1 = floor( 0.5 + (fromIntegral ((n - 1) * s) :: Float) / fromIntegral (m'-1)) + | m' == 1 = if s == 0 + then + quot n 2 + else + maxBound + | otherwise = assert (m' == 0) maxBound + + +verifyResample :: [a] + -- ^ the input + -> Int + -- ^ the number of samples + -> [a] + -- ^ the output + -> Bool +verifyResample input nSamples resampled + | nSamples == length resampled = True + | otherwise = error $ "\ninput " ++ show (length input) ++ + "\nnSamples " ++ show nSamples ++ + "\nactual " ++ show (length resampled) diff --git a/src/Imj/Geo/Discrete/Types.hs b/src/Imj/Geo/Discrete/Types.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Geo/Discrete/Types.hs @@ -0,0 +1,167 @@ +{-# OPTIONS_HADDOCK prune #-} +{-# OPTIONS_HADDOCK hide #-} + +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleInstances #-} + +-- | Types for discrete geometry. + +module Imj.Geo.Discrete.Types + ( + -- * Discrete geometry types + -- ** Direction + Direction(..) + -- ** Coordinates + , Coords(..) + , Coord(..), Col, Row + -- ** Size + , Size(..) + , Length(..) + , Width + , Height + , toCoords + , maxLength + , onOuterBorder + , containsWithOuterBorder + -- ** Segment + , Segment(..) + , mkSegment + -- * Bresenham line algorithm + , bresenhamLength + , bresenham + -- * Reexports + , Pos, Vel + ) where + +import Imj.Prelude + +import Imj.Geo.Discrete.Bresenham +import Imj.Geo.Types +import Imj.Graphics.Class.DiscreteInterpolation +import Imj.Util + +-- | Discrete directions. +data Direction = Up | Down | LEFT | RIGHT deriving (Eq, Show) + +-- | Discrete coordinate. +newtype Coord a = Coord Int + deriving (Eq, Num, Ord, Integral, Real, Enum, Show) + +-- | Using bresenham 2d line algorithm. +instance DiscreteInterpolation (Coords Pos) where + interpolate c c' i + | c == c' = c + | otherwise = + let lastFrame = pred $ fromIntegral $ bresenhamLength c c' + -- TODO measure if "head . drop (pred n)"" is more optimal than "!! n" + index = clamp i 0 lastFrame + in head . drop index $ bresenham $ mkSegment c c' + +-- | Using bresenham 2d line algorithm. +instance DiscreteDistance (Coords Pos) where + distance = bresenhamLength + +-- | Represents a row index (y) +data Row +-- | Represents a column index (x) +data Col + +-- | Two-dimensional discrete coordinates. We use phantom types 'Pos', 'Vel' +-- to distinguish positions from speeds. +data Coords a = Coords { + _coordsY :: {-# UNPACK #-} !(Coord Row) + , _coordsX :: {-# UNPACK #-} !(Coord Col) +} deriving (Eq, Show, Ord) + +-- | Discrete length +newtype Length a = Length Int + deriving (Eq, Num, Ord, Integral, Real, Enum, Show) + +-- | Phantom type for width +data Width +-- | Phantom type for height +data Height +-- | Represents a discrete size (width and height) +data Size = Size { + _sizeY :: {-# UNPACK #-} !(Length Height) + , _sizeX :: {-# UNPACK #-} !(Length Width) +} deriving (Eq, Show) + +-- | Width and Height to Coords +toCoords :: Length Height -> Length Width -> Coords Pos +toCoords (Length h) (Length w) = + Coords (Coord h) (Coord w) + +-- | Returns the bigger dimension (width or height) +maxLength :: Size -> Int +maxLength (Size (Length h) (Length w)) = + max w h + +-- | Tests if a 'Coords' lies on the outer border of a region of a given size, +-- containing (0,0) and positive coordinates. +onOuterBorder :: Coords Pos + -- ^ The coordinates to test + -> Size + -- ^ The size + -> Maybe Direction + -- ^ If the coordinates are on the border, returns a 'Direction' pointing + -- away from the region (at the given coordinates). +onOuterBorder (Coords r c) (Size rs cs) + | r == -1 = Just Up + | c == -1 = Just LEFT + | r == fromIntegral rs = Just Down + | c == fromIntegral cs = Just RIGHT + | otherwise = Nothing + +-- | Tests if a 'Coords' is contained or on the outer border of a region +-- of a given size, containing (0,0) and positive coordinates. +containsWithOuterBorder :: Coords Pos -> Size -> Bool -- TODO simplify, pass a number for the outer border size +containsWithOuterBorder (Coords r c) (Size rs cs) + = r >= -1 && c >= -1 && r <= fromIntegral rs && c <= fromIntegral cs + +-- | A segment is a line betwen two discrete coordinates. +-- +-- It can be materialized as a list of 'Coords' using 'bresenham' +data Segment = Horizontal !(Coord Row) !(Coord Col) !(Coord Col) + -- ^ Horizontal segment + | Vertical !(Coord Col) !(Coord Row) !(Coord Row) + -- ^ Vertical segment + | Oblique !(Coords Pos) !(Coords Pos) + -- ^ Oblique segment + deriving(Show) + +mkSegment :: Coords Pos + -- ^ Segment start + -> Coords Pos + -- ^ Segment end + -> Segment +mkSegment coord1@(Coords r1 c1) coord2@(Coords r2 c2) + | r1 == r2 = Horizontal r1 c1 c2 + | c1 == c2 = Vertical c1 r1 r2 + | otherwise = Oblique coord1 coord2 + + +-- | Returns the bresenham 2d distance between two coordinates. +bresenhamLength :: Coords Pos -> Coords Pos -> Int +bresenhamLength (Coords r1 c1) (Coords r2 c2) + = succ $ max (fromIntegral (abs (r1-r2))) $ fromIntegral (abs (c1-c2)) + +-- | Bresenham 2d algorithm, slightly optimized for horizontal and vertical lines. +bresenham :: Segment -> [Coords Pos] +bresenham (Horizontal r c1 c2) = map (Coords r) $ range c1 c2 +bresenham (Vertical c r1 r2) = map (flip Coords c) $ range r1 r2 +bresenham (Oblique (Coords y0 x0) c2@(Coords y1 x1)) = + takeWhileInclusive (/= c2) + $ map (\(x,y) -> Coords (Coord y) (Coord x) ) + $ bla (fromIntegral x0,fromIntegral y0) + (fromIntegral x1,fromIntegral y1) + +takeWhileInclusive :: (a -> Bool) -> [a] -> [a] +takeWhileInclusive _ [] = [] +takeWhileInclusive p (x:xs) = + x : if p x + then + takeWhileInclusive p xs + else + [] diff --git a/src/Imj/Geo/Types.hs b/src/Imj/Geo/Types.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Geo/Types.hs @@ -0,0 +1,15 @@ +{-# OPTIONS_HADDOCK hide #-} + +module Imj.Geo.Types + ( Pos, Vel, Acc + ) where + + +-- | Phantom type : position +data Pos + +-- | Phantom type : velocity +data Vel + +-- | Phantom type : acceleration +data Acc diff --git a/src/Imj/Graphics/Class.hs b/src/Imj/Graphics/Class.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Graphics/Class.hs @@ -0,0 +1,13 @@ +-- doc module + +module Imj.Graphics.Class + ( -- * Classes + -- | A collection of classes representing graphical elements and their properties. + module Imj.Graphics.Class.HasLayeredColor + , module Imj.Graphics.Class.Colorable + , module Imj.Graphics.Class.Drawable + ) where + +import Imj.Graphics.Class.Colorable +import Imj.Graphics.Class.Drawable +import Imj.Graphics.Class.HasLayeredColor diff --git a/src/Imj/Graphics/Class/Colorable.hs b/src/Imj/Graphics/Class/Colorable.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Graphics/Class/Colorable.hs @@ -0,0 +1,20 @@ +{-# OPTIONS_HADDOCK hide #-} + +{-# LANGUAGE NoImplicitPrelude #-} + +module Imj.Graphics.Class.Colorable + ( Colorable(..) + ) where + + +import Control.Monad.IO.Class(MonadIO) +import Control.Monad.Reader.Class(MonadReader) + +import Imj.Graphics.Class.Draw +import Imj.Graphics.Color.Types + +-- | A 'Colorable' is a colourless graphical element. +class Colorable a where-- TODO add HasPosition constraint here + -- | To draw a 'Colorable', we need to pass a 'LayeredColor'. + drawUsingColor :: (Draw e, MonadReader e m, MonadIO m) + => a -> LayeredColor -> m () diff --git a/src/Imj/Graphics/Class/DiscreteColorableMorphing.hs b/src/Imj/Graphics/Class/DiscreteColorableMorphing.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Graphics/Class/DiscreteColorableMorphing.hs @@ -0,0 +1,55 @@ +{-# OPTIONS_HADDOCK hide #-} + +{-# LANGUAGE NoImplicitPrelude #-} + +module Imj.Graphics.Class.DiscreteColorableMorphing + ( DiscreteColorableMorphing(..) + -- * Reexports + , module Imj.Graphics.Class.DiscreteDistance + , module Imj.Graphics.Class.Colorable + , module Imj.Graphics.Class.DiscreteMorphing -- for haddock link + ) where + +import Imj.Prelude + + +import Control.Monad.IO.Class(MonadIO) +import Control.Monad.Reader.Class(MonadReader) + +import Imj.Graphics.Color.Types +import Imj.Graphics.Class.DiscreteDistance +import Imj.Graphics.Class.Draw +import Imj.Graphics.Class.Colorable +import Imj.Graphics.Class.DiscreteMorphing + +{- | Like 'DiscreteMorphing', except the +'Drawable' constraint is replaced by a 'Colorable' constraint: + +Morph between /drawn/ representations of 'Colorable'. + +[Drawn representation of 'Colorable' x] +The visual result of IO rendering commands induced by a 'drawUsingColor' @x@ call. + +Instances should statisfy the following constraints: + +* A morphing between /drawn/ representations of A and B start at the /drawn/ +representation of A and ends at the /drawn/ represntation of B: + +\( \forall (\, from, to)\, \in v, \forall color \) + +@ + d = distance from to + drawMorphingUsingColor from to 0 color "is the same as" drawUsingColor from color + drawMorphingUsingColor from to d color "is the same as" drawUsingColor to color +@ + +* The morphing path is composed of strictly distinct /drawings/. +* The /drawings/, when seen in rapid succession, should visually produce a +/smooth/ transformation from the first to the last /drawing/.-} +class (DiscreteDistance a, Colorable a) + => DiscreteColorableMorphing a where + + -- | A 'Colorable' is colourless so it wouldn't know in which color to draw itself, + -- hence here we pass a 'LayeredColor'. + drawMorphingUsingColor :: (Draw e, MonadReader e m, MonadIO m) + => a -> a -> Int -> LayeredColor -> m () diff --git a/src/Imj/Graphics/Class/DiscreteDistance.hs b/src/Imj/Graphics/Class/DiscreteDistance.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Graphics/Class/DiscreteDistance.hs @@ -0,0 +1,54 @@ +{-# OPTIONS_HADDOCK hide #-} + +{-# LANGUAGE NoImplicitPrelude #-} + +module Imj.Graphics.Class.DiscreteDistance + ( DiscreteDistance(..) + , Successive(..) + ) where + +import Imj.Prelude + +import Data.List( length ) + +-- | Wrapper on a list, to represents successive waypoints. +newtype Successive a = Successive [a] deriving(Show) + +{- | Instances should satisfy: + +\( \forall (\, from, to)\, \in v, \) + +* 'distance' @from to@ >= 0 +* 'distance' @from to@ can be different from 'distance' @to from@, +to provide different forward and backward interpolations (or morphings). +-} +class DiscreteDistance v where + -- | Distance between two 'DiscreteDistance's. + distance :: v -- ^ first value + -> v -- ^ last value + -> Int -- ^ the number of steps (including first and last) to go from first to last + + -- | Distance between n successive 'DiscreteDistance's. + distanceSuccessive :: Successive v + -> Int + distanceSuccessive (Successive []) = + error "empty successive" + distanceSuccessive (Successive l@(_:_)) = + succ $ sum $ zipWith (\a b -> pred $ distance a b) l $ tail l + +-- | Naïve interpolation. +instance DiscreteDistance Int where + distance i i' = + 1 + abs (i-i') + +-- | Interpolation between 2 lists, occuring in parallel between same-index elements. +-- Prerequisite : lists have the same lengths. +-- +-- For an interpolation that occurs sequentially between same-index elements, +-- use SequentiallyInterpolatedList. +instance (DiscreteDistance a) + => DiscreteDistance ([] a) where + distance [] _ = 1 + distance _ [] = 1 + distance l l' = + maximum $ zipWith distance l $ assert (length l == length l') l' diff --git a/src/Imj/Graphics/Class/DiscreteInterpolation.hs b/src/Imj/Graphics/Class/DiscreteInterpolation.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Graphics/Class/DiscreteInterpolation.hs @@ -0,0 +1,79 @@ +{-# OPTIONS_HADDOCK hide #-} + +{-# LANGUAGE NoImplicitPrelude #-} + +module Imj.Graphics.Class.DiscreteInterpolation + ( DiscreteInterpolation(..) + -- * Reexport + , module Imj.Graphics.Class.DiscreteDistance + ) where + +import Imj.Prelude + +import Data.List(length) + +import Imj.Graphics.Class.DiscreteDistance +import Imj.Util + + +{- | Instances should statisfy the following constraints: + +* An interpolation between A and B starts at A and ends at B: + +\( \forall (\, from, to)\, \in v, \) + +@ + d = distance from to + interpolate from to 0 == from + interpolate from to d == to +@ + +* The interpolation path is composed of strictly distinct points: + +@ + length $ nubOrd $ map (interpolate from to) [0..pred d] == d +@ + +* Given any points A,B belonging the path generated by an interpolation, + the interpolation beween A and B will be the points of the path between A and B: + +\( \forall med \in [\,0,d]\,, \forall low \in [\,0,med]\,, \forall high \in [\,med,d]\,, \) + +@ + distance from med + distance med to == 1 + distance from to + medVal = interpolate from to med + interpolate from to low == interpolate from medVal low + interpolate from to high == interpolate medVal to $ high-med +@ +-} +class (DiscreteDistance v) => DiscreteInterpolation v where + -- | Implement this function if you want to interpolate /by value/, i.e the result of + -- the interpolation between two \(v\) is a \(v\). + interpolate :: v -- ^ first value + -> v -- ^ last value + -> Int -- ^ the current step + -> v -- ^ the interpolated value + + interpolateSuccessive :: Successive v + -> Int + -> v + interpolateSuccessive (Successive []) _ = error "empty successive" + interpolateSuccessive (Successive [a]) _ = a + interpolateSuccessive (Successive l@(a:b:_)) i + | i <= 0 = a + | i >= lf = interpolateSuccessive (Successive $ tail l) $ i-lf + | otherwise = interpolate a b i + where lf = pred $ distance a b + +-- | Naïve interpolation. +instance DiscreteInterpolation Int where + interpolate i i' progress = + i + signum (i'-i) * clamp progress 0 (abs (i-i')) + + +-- | Interpolate in parallel between 2 lists : each pair of same-index elements +-- is interpolated at the same time. +instance (DiscreteInterpolation a) + => DiscreteInterpolation ([] a) where + interpolate l l' progress = + zipWith (\e e' -> interpolate e e' progress) l $ assert (length l == length l') l' diff --git a/src/Imj/Graphics/Class/DiscreteMorphing.hs b/src/Imj/Graphics/Class/DiscreteMorphing.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Graphics/Class/DiscreteMorphing.hs @@ -0,0 +1,68 @@ +{-# OPTIONS_HADDOCK hide #-} + +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE FlexibleInstances #-} + +module Imj.Graphics.Class.DiscreteMorphing + ( DiscreteMorphing(..) + -- * Reexport + , module Imj.Graphics.Class.DiscreteDistance + , module Imj.Graphics.Class.Drawable + , module Imj.Graphics.Class.Draw + , MonadIO + , MonadReader + ) where + +import Imj.Prelude + +import Control.Monad.IO.Class(MonadIO) +import Control.Monad.Reader.Class(MonadReader) + +import Imj.Graphics.Class.DiscreteDistance +import Imj.Graphics.Class.Draw +import Imj.Graphics.Class.Drawable + + +{-| Morph between /drawn/ representations of 'Drawble's. + +[Drawn representation of 'Drawable' x] +The visual result of IO rendering commands induced by a 'draw' @x@ call. + +Instances should statisfy the following constraints: + +* A morphing between /drawn/ representations of A and B starts at the /drawn/ +representation of A and ends at the /drawn/ represntation of B: + +\( \forall (\, from, to)\, \in v, \) + +@ + d = distance from to + drawMorphing from to 0 "is the same as" draw from + drawMorphing from to d "is the same as" draw to +@ + +* The morphing path is composed of strictly distinct /drawings/. +* The /drawings/, when seen in rapid succession, should visually produce a +/smooth/ transformation from the first to the last /drawing/. -} +class (DiscreteDistance v, Drawable v) + => DiscreteMorphing v where + -- | Draws the morphing between the /drawn/ representations of 2 \(v\). + drawMorphing :: (Draw e, MonadReader e m, MonadIO m) + => v -- ^ first value + -> v -- ^ last value + -> Int -- ^ the current step + -> m () + + -- | Draws the morphing between the /drawn/ representations of several \(v\). + {-# INLINABLE drawMorphingSuccessive #-} + drawMorphingSuccessive :: (Draw e, MonadReader e m, MonadIO m) + => Successive v + -> Int + -> m () + drawMorphingSuccessive (Successive []) _ = error "empty successive" + drawMorphingSuccessive (Successive [a]) _ = drawMorphing a a 0 + drawMorphingSuccessive (Successive l@(a:b:_)) i + | i <= 0 = drawMorphing a a 0 + | i >= lf = drawMorphingSuccessive (Successive $ tail l) $ i-lf + | otherwise = drawMorphing a b i + where lf = pred $ distance a b diff --git a/src/Imj/Graphics/Class/Draw.hs b/src/Imj/Graphics/Class/Draw.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Graphics/Class/Draw.hs @@ -0,0 +1,67 @@ +{-# OPTIONS_HADDOCK hide #-} + +{-# LANGUAGE NoImplicitPrelude #-} + +module Imj.Graphics.Class.Draw( + Draw(..) + ) where + +import Imj.Prelude + +import Control.Monad(foldM_) +import Control.Monad.IO.Class(MonadIO) +import Data.Text(Text, length) + +import Imj.Geo.Discrete +import Imj.Graphics.Color.Types +import Imj.Graphics.Text.Alignment +import Imj.Graphics.Text.ColorString + + +--'drawChars'', 'drawTxt'' and 'drawStr'' could have been default-implemented in terms +--of 'drawChar', but the implementation would have been suboptimal in most cases. +class Draw e where + -- | Draw a 'Char'. + drawChar' :: (MonadIO m) => e -> Char -> Coords Pos -> LayeredColor -> m () + -- | Draw repeated chars. + drawChars' :: (MonadIO m) => e -> Int -> Char -> Coords Pos -> LayeredColor -> m () + -- | Draw 'Text'. + drawTxt' :: (MonadIO m) => e -> Text -> Coords Pos -> LayeredColor -> m () + -- | Draw 'String'. + drawStr' :: (MonadIO m) => e -> String -> Coords Pos -> LayeredColor -> m () + + -- | Draw a 'ColorString'. + {-# INLINABLE drawColorStr' #-} + drawColorStr' :: (MonadIO m) => e -> ColorString -> Coords Pos -> m () + drawColorStr' env (ColorString cs) pos = + foldM_ + (\count (txt, color) -> do + let l = length txt + drawTxt' env txt (move count RIGHT pos) color + return $ count + l + ) 0 cs + + -- | Draw text aligned w.r.t alignment and reference coordinates. + {-# INLINABLE drawAlignedTxt_' #-} + drawAlignedTxt_' :: (MonadIO m) => e -> Text -> LayeredColor -> Alignment -> m () + drawAlignedTxt_' env txt colors a = do + let leftCorner = align' a (length txt) + drawTxt' env txt leftCorner colors + + -- | Draws text aligned w.r.t alignment and reference coordinates. + -- + -- Returns an 'Alignment' where the reference coordinate of the input 'Alignment' + -- was projected on the next line. + {-# INLINABLE drawAlignedTxt' #-} + drawAlignedTxt' :: (MonadIO m) => e -> Text -> LayeredColor -> Alignment -> m Alignment + drawAlignedTxt' env txt colors a = + drawAlignedTxt_' env txt colors a + >> return (toNextLine a) + + -- | Draw a 'ColorString' with an 'Alignment' constraint. + {-# INLINABLE drawAlignedColorStr' #-} + drawAlignedColorStr' :: (MonadIO m) => e -> Alignment -> ColorString -> m Alignment + drawAlignedColorStr' env a cs = do + let leftCorner = align' a (countChars cs) + _ <- drawColorStr' env cs leftCorner + return $ toNextLine a diff --git a/src/Imj/Graphics/Class/Drawable.hs b/src/Imj/Graphics/Class/Drawable.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Graphics/Class/Drawable.hs @@ -0,0 +1,19 @@ +{-# OPTIONS_HADDOCK hide #-} + +{-# LANGUAGE NoImplicitPrelude #-} + +module Imj.Graphics.Class.Drawable + ( Drawable(..) + ) where + +import Control.Monad.IO.Class(MonadIO) +import Control.Monad.Reader.Class(MonadReader) + +import Imj.Graphics.Class.Draw + +-- | A 'Drawable' is a graphical element that knows how to draw itself +-- (it knows its color and position). +class Drawable a where + -- | Draw the 'Drawable' + draw :: (Draw e, MonadReader e m, MonadIO m) + => a -> m () diff --git a/src/Imj/Graphics/Class/HasLayeredColor.hs b/src/Imj/Graphics/Class/HasLayeredColor.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Graphics/Class/HasLayeredColor.hs @@ -0,0 +1,13 @@ +{-# OPTIONS_HADDOCK hide #-} + +{-# LANGUAGE NoImplicitPrelude #-} + +module Imj.Graphics.Class.HasLayeredColor + ( HasLayeredColor(..) + ) where + +import Imj.Graphics.Color.Types + +-- | Access one graphical element's 'LayeredColor'. +class HasLayeredColor a where + getColor :: a -> LayeredColor diff --git a/src/Imj/Graphics/Class/Render.hs b/src/Imj/Graphics/Class/Render.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Graphics/Class/Render.hs @@ -0,0 +1,20 @@ +{-# OPTIONS_HADDOCK hide #-} + +{-# LANGUAGE NoImplicitPrelude #-} + +module Imj.Graphics.Class.Render( + Render(..) + ) where + +import Control.Monad.IO.Class(MonadIO) + +import Imj.Graphics.Class.Draw + +{- | Class describing the ability to render the result of a 'Draw' to the +screen. + +It is left to the implementation to decide wether to clear the screen or not (after a +'renderToScreen' for example), and with which color. -} +class (Draw e) => Render e where + -- | Render to the screen. + renderToScreen' :: (MonadIO m) => e -> m () diff --git a/src/Imj/Graphics/Color.hs b/src/Imj/Graphics/Color.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Graphics/Color.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Imj.Graphics.Color + ( + -- * 8-bits colors + {- | There are + . + Here, we support 8-bit colors. + + 8-bit colors have 6*6*6 = 216 rgb colors, 24 grays and are represented by + 'Color8'. You can create a 'Color8' ny using 'rgb' or 'gray'. + + It is possible to /interpolate/ between two colors in RGB space using the + 'DiscreteInterpolation' instance of 'Color8'. + + We also have 'LayeredColor' because when drawing in the terminal, we can + change both the 'Background' and the 'Foreground' color. + -} + Color8 -- constructor is intentionaly not exposed. + -- ** Create a single color + , rgb + , gray + -- ** Create a LayeredColor + , LayeredColor(..) + , Background + , Foreground + , onBlack + , whiteOnBlack + -- ** Predefined colors + , white, black, red, green, magenta, cyan, yellow, blue + ) where + + +import Imj.Graphics.Color.Types + +-- For reference: +{- +import Imj.Prelude +-- | How +-- +xtermMapRGB8bitComponent :: Word8 + -- ^ input values are in + -- + -> Word8 + -- ^ output is in range [0..255] +xtermMapRGB8bitComponent 0 = 0 +xtermMapRGB8bitComponent n = 55 + n * 40 + +-- | How +-- +xtermMapGray8bitComponent :: Word8 + -- ^ input values are in + -- + -> Word8 + -- ^ output is in range [0..255] +xtermMapGray8bitComponent v = 8 + 10 * v +-} diff --git a/src/Imj/Graphics/Color/Types.hs b/src/Imj/Graphics/Color/Types.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Graphics/Color/Types.hs @@ -0,0 +1,305 @@ +{-# OPTIONS_HADDOCK hide #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Imj.Graphics.Color.Types + ( Color8 -- constructor is intentionaly not exposed. + , mkColor8 + , Background + , Foreground + , LayeredColor(..) + , encodeColors + , color8BgSGRToCode + , color8FgSGRToCode + , Word8 + , bresenhamColor8 + , bresenhamColor8Length + , rgb + , gray + , Xterm256Color(..) + , onBlack + , whiteOnBlack + , white, black, red, green, magenta, cyan, yellow, blue + , RGB(..) + ) where + +import Data.Bits(shiftL, (.|.)) +import Data.Word (Word8, Word16) + +import Imj.Geo.Discrete.Bresenham3 +import Imj.Graphics.Class.DiscreteDistance +import Imj.Graphics.Class.DiscreteInterpolation +import Imj.Util + +-- | Components are expected to be between 0 and 5 included. +data RGB = RGB { + _rgbR :: {-# UNPACK #-} !Word8 + , _rgbG :: {-# UNPACK #-} !Word8 + , _rgbB :: {-# UNPACK #-} !Word8 +} deriving(Eq, Show, Read) + +-- | A background and a foreground 'Color8'. +data LayeredColor = LayeredColor { + _colorsBackground :: {-# UNPACK #-} !(Color8 Background) + , _colorsForeground :: {-# UNPACK #-} !(Color8 Foreground) +} deriving(Eq, Show) + +-- TODO use bresenham 6 to interpolate foreground and background at the same time: +-- https://nenadsprojects.wordpress.com/2014/08/08/multi-dimensional-bresenham-line-in-c/ +-- | First interpolate background color, then foreground color +instance DiscreteDistance LayeredColor where + distance (LayeredColor bg fg) (LayeredColor bg' fg') = + succ $ pred (distance bg bg') + pred (distance fg fg') + +-- | First interpolate background color, then foreground color +instance DiscreteInterpolation LayeredColor where + interpolate (LayeredColor bg fg) (LayeredColor bg' fg') i + | i < lastBgFrame = LayeredColor (interpolate bg bg' i) fg + | otherwise = LayeredColor bg' $ interpolate fg fg' $ i - lastBgFrame + where + lastBgFrame = pred $ distance bg bg' + + +{-# INLINE encodeColors #-} +encodeColors :: LayeredColor -> Word16 +encodeColors (LayeredColor (Color8 bg') (Color8 fg')) = + let fg = fromIntegral fg' :: Word16 + bg = fromIntegral bg' :: Word16 + in (bg `shiftL` 8) .|. fg + + +-- | Creates a rgb 'Color8' as defined in +-- +-- +-- Input components are expected to be in range [0..5] +rgb :: Word8 + -- ^ red component in [0..5] + -> Word8 + -- ^ green component in [0..5] + -> Word8 + -- ^ blue component in [0..5] + -> Color8 a +rgb r g b + | r >= 6 || g >= 6 || b >= 6 = error "out of range" + | otherwise = Color8 $ fromIntegral $ 16 + 36 * r + 6 * g + b + + +-- | Creates a gray 'Color8' as defined in +-- +-- +-- Input is expected to be in the range [0..23] (from darkest to lightest) +gray :: Word8 + -- ^ gray value in [0..23] + -> Color8 a +gray i + | i >= 24 = error "out of range gray" + | otherwise = Color8 $ fromIntegral (i + 232) + + +data Foreground +data Background +-- | ANSI allows for a palette of up to 256 8-bit colors. +newtype Color8 a = Color8 Word8 deriving (Eq, Show, Read, Enum) + +-- | Using bresenham 3D algorithm in RGB space. +instance DiscreteDistance (Color8 a) where + -- | The two input 'Color8' are expected to be both 'rgb' or both 'gray'. + distance = bresenhamColor8Length + +-- | Using bresenham 3D algorithm in RGB space. +instance DiscreteInterpolation (Color8 a) where + -- | The two input 'Color8' are supposed to be both 'rgb' or both 'gray'. + interpolate c c' i + | c == c' = c + | otherwise = + let lastFrame = pred $ fromIntegral $ bresenhamColor8Length c c' + -- TODO measure if "head . drop (pred n)"" is more optimal than "!! n" + index = clamp i 0 lastFrame + in head . drop index $ bresenhamColor8 c c' + + +{-# INLINE mkColor8 #-} +mkColor8 :: Word8 -> Color8 a +mkColor8 = Color8 + +-- | Converts a 'Color8' 'Foreground' to corresponding +-- . +color8FgSGRToCode :: Color8 Foreground -> [Int] +color8FgSGRToCode (Color8 c) = + [38, 5, fromIntegral c] + +-- | Converts a 'Color8' 'Background' to corresponding +-- . +color8BgSGRToCode :: Color8 Background -> [Int] +color8BgSGRToCode (Color8 c) = + [48, 5, fromIntegral c] + +-- | Computes the bresenham length between two colors. If both are 'gray', the +-- interpolation happens in grayscale space. +{-# INLINABLE bresenhamColor8Length #-} +bresenhamColor8Length :: Color8 a -> Color8 a -> Int +bresenhamColor8Length c c' + | c == c' = 1 + | otherwise = case (color8CodeToXterm256 c, color8CodeToXterm256 c') of + (GrayColor g1, GrayColor g2) -> 1 + fromIntegral (abs (g2 - g1)) + (RGBColor rgb1, RGBColor rgb2) -> bresenhamRGBLength rgb1 rgb2 + (RGBColor rgb1, GrayColor g2) -> bresenhamRGBLength rgb1 (grayToRGB rgb1 g2) + (GrayColor g1, RGBColor rgb2) -> bresenhamRGBLength (grayToRGB rgb2 g1) rgb2 + +{- | Returns the bresenham path between two colors. + +If both are 'gray', the interpolation happens in grayscale space. + +If one is a 'gray' and the other 'rgb', the 'gray' one will be approximated by +the closest 'rgb' in the direction of the other color, so as to produce +a /monotonic/ interpolation. -} +{-# INLINABLE bresenhamColor8 #-} +bresenhamColor8 :: Color8 a -> Color8 a -> [Color8 a] +bresenhamColor8 c c' + | c == c' = [c] + | otherwise = case (color8CodeToXterm256 c, color8CodeToXterm256 c') of + (GrayColor g1, GrayColor g2) -> map Color8 $ range g1 g2 + (RGBColor rgb1, RGBColor rgb2) -> mapBresRGB rgb1 rgb2 + (RGBColor rgb1, GrayColor g2) -> mapBresRGB rgb1 (grayToRGB rgb1 g2) + (GrayColor g1, RGBColor rgb2) -> mapBresRGB (grayToRGB rgb2 g1) rgb2 + where + mapBresRGB c1 c2 = map (xterm256ColorToCode . RGBColor) $ bresenhamRGB c1 c2 + +{-# INLINABLE bresenhamRGBLength #-} +bresenhamRGBLength :: RGB -> RGB -> Int +bresenhamRGBLength (RGB r g b) (RGB r' g' b') = + bresenham3Length (fromIntegral r,fromIntegral g,fromIntegral b) (fromIntegral r',fromIntegral g',fromIntegral b') + +{-# INLINABLE bresenhamRGB #-} +bresenhamRGB :: RGB -> RGB -> [RGB] +bresenhamRGB (RGB r g b) (RGB r' g' b') = + map + (\(x,y,z) -> RGB (fromIntegral x) (fromIntegral y) (fromIntegral z)) + $ bresenham3 (fromIntegral r ,fromIntegral g ,fromIntegral b ) + (fromIntegral r',fromIntegral g',fromIntegral b') + + +-- | Converts a 'Color8' to a 'Xterm256Color'. +color8CodeToXterm256 :: Color8 a -> Xterm256Color a +color8CodeToXterm256 (Color8 c) + | c < 16 = error "interpolating 4-bit system colors is not supported" -- 4-bit ANSI color + | c < 232 = RGBColor $ asRGB (c - 16) -- interpreted as 8-bit rgb + | otherwise = GrayColor (c - 232) -- interpreted as 8-bit grayscale + where + asRGB i = let -- we know that i = 36 × r + 6 × g + b and (0 ≤ r, g, b ≤ 5) + -- (cf. comment on top) so we can deduce the unique set of + -- corresponding r g and b values: + r = quot i 36 + g = quot (i - 36 * r) 6 + b = i - (6 * g + 36 * r) + in RGB r g b + +-- For safety the values of RGBColor and GrayColor are clamped to their respective ranges. +-- | Converts a 'Xterm256Color' to a 'Color8'. +xterm256ColorToCode :: Xterm256Color a -> Color8 a +-- 8-bit rgb colors are represented by code: +-- 16 + 36 × r + 6 × g + b (0 ≤ r, g, b ≤ 5) (see link to spec above) +xterm256ColorToCode (RGBColor (RGB r' g' b')) + = Color8 (16 + 36 * r + 6 * g + b) + where + clamp' x = clamp x 0 5 + r = clamp' r' + g = clamp' g' + b = clamp' b' +-- 8-bit grayscale colors are represented by code: 232 + g (g in [0..23]) (see +-- link to spec above) +xterm256ColorToCode (GrayColor y) = Color8 (232 + clamp y 0 23) + +-- | Represents the rgb and grayscale xterm 256 colors +-- +-- The ranges of colors that can be represented by each constructor are specified +-- . +data Xterm256Color a = RGBColor !RGB + -- ^ corresponding ANSI range: + -- + -- - [0x10-0xE7]: 6 × 6 × 6 cube (216 colors): + -- 16 + 36 × r + 6 × g + b (0 ≤ r, g, b ≤ 5) + | GrayColor !Word8 + -- ^ corresponding ANSI range: + -- + -- - [0xE8-0xFF]: grayscale from dark gray to near white in 24 steps + deriving (Eq, Show, Read) + + +{-# INLINE onBlack #-} +-- | Creates a 'LayeredColor' with a black background color. +onBlack :: Color8 Foreground -> LayeredColor +onBlack = LayeredColor (rgb 0 0 0) + +{-# INLINE whiteOnBlack #-} +-- | Creates a 'LayeredColor' with white foreground and black background color. +whiteOnBlack :: LayeredColor +whiteOnBlack = onBlack white + +red, green, blue, yellow, magenta, cyan, white, black :: Color8 a +red = rgb 5 0 0 +green = rgb 0 5 0 +blue = rgb 0 0 5 +yellow = rgb 5 5 0 +magenta = rgb 5 0 5 +cyan = rgb 0 5 5 +white = rgb 5 5 5 +black = rgb 0 0 0 + + + +-- | converts a GrayColor to a RGBColor, using another RGBColor +-- to know in which way to approximate. +grayToRGB :: RGB + -- ^ We'll round the resulting r,g,b components towards this color + -> Word8 + -- ^ The gray component + -> RGB +grayToRGB (RGB r g b) grayComponent = + RGB (approximateGrayComponentAsRGBComponent r grayComponent) + (approximateGrayComponentAsRGBComponent g grayComponent) + (approximateGrayComponentAsRGBComponent b grayComponent) + + +approximateGrayComponentAsRGBComponent :: Word8 + -- ^ rgb target component to know in which way to appoximate + -> Word8 + -- ^ gray component + -> Word8 + -- ^ rgb component +approximateGrayComponentAsRGBComponent _ 0 = 0 +approximateGrayComponentAsRGBComponent _ 1 = 0 +approximateGrayComponentAsRGBComponent colorComponent grayComponent = + let c = grayComponentToFollowingRGBComponent grayComponent + in if colorComponent < c + then + -- using the /following/ component, we went in the wrong direction + -- so we take the previous one. + pred c + else + -- using the /following/ component, we went in the right direction + c + +{- Gives the first RGB component that has a color value strictly greater +than the color value of the gray component. + +Using implementations of 'xtermMapGray8bitComponent' and 'xtermMapRGB8bitComponent' +we can deduce the following correspondances, where we align values: +@ +rgb val: 0 95 135 175 215 255 +rgb idx: 0 1 2 3 4 5 +gray idx: 0 1 8 9 12 13 16 17 20 21 23 +gray val: 8 18.. 88 98.. 128 138.. 168 178.. 208 218.. 238 +@ + +Note that no 2 color values match between rgb and gray. +-} +grayComponentToFollowingRGBComponent :: Word8 + -- ^ gray component + -> Word8 + -- ^ rgb component +grayComponentToFollowingRGBComponent g + | g > 20 = 5 + | g > 16 = 4 + | g > 12 = 3 + | g > 8 = 2 + | otherwise = 1 diff --git a/src/Imj/Graphics/Interpolation.hs b/src/Imj/Graphics/Interpolation.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Graphics/Interpolation.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Imj.Graphics.Interpolation + ( -- * Discrete interpolation and morphing + {- | + * 'DiscreteInterpolation' describes interpolation /by value/ + , where the result of the interpolation between two \(v\) is a \(v\) + * 'DiscreteMorphing' and 'DiscreteColorableMorphing' describe a morphing between + /drawn/ representations of \(v\). + + These classes rely on the 'DiscreteDistance' class: + -} + DiscreteDistance(..) + , Successive(..) + -- ** Interpolation + , DiscreteInterpolation(..) + -- ** Morphing + , DiscreteMorphing(..) + , DiscreteColorableMorphing(..) + -- * Lists interpolations + {-| The 'DiscreteInterpolation' instance on [] defines a parallel + interpolation (interpolation occurs at the same time for all same-index + elements). + + To interpolate sequentially (i.e one index at a time), use + 'SequentiallyInterpolatedList' instead:-} + , SequentiallyInterpolatedList(..) + , module Imj.Graphics.Interpolation.Evolution + -- * Reexports + , module Imj.Iteration + ) where + +import Imj.Graphics.Class.DiscreteInterpolation +import Imj.Graphics.Class.DiscreteColorableMorphing +import Imj.Graphics.Interpolation.Evolution +import Imj.Graphics.Interpolation.SequentiallyInterpolatedList +import Imj.Iteration diff --git a/src/Imj/Graphics/Interpolation/Evolution.hs b/src/Imj/Graphics/Interpolation/Evolution.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Graphics/Interpolation/Evolution.hs @@ -0,0 +1,148 @@ +{-# OPTIONS_HADDOCK hide #-} + +{-# LANGUAGE NoImplicitPrelude #-} + +module Imj.Graphics.Interpolation.Evolution + ( + -- * Evolution +{- | 'Evolution' is a helper type to interpolate between 'DiscreteInterpolation's +or morph between 'DiscreteMorphing'. + +It stores the 'distance' to cache potential expensive distance computations. + +The preferred way to create it is to use 'mkEvolutionEaseQuart' which uses the +inverse ease function 'invQuartEaseInOut'. + +To produce the desired /easing/ effect, the 'Evolution' should be updated +at specific time intervals. In that respect, 'getDeltaTimeToNextFrame' +computes the next time at which the interpolation should be updated (for interpolations) +or rendered (for morphings), based on the current frame and the inverse ease function. +-} + Evolution(..) + , mkEvolutionEaseQuart + , mkEvolution + , getDeltaTimeToNextFrame + -- ** Getting an interpolated value + , getValueAt + -- ** Draw a morphing + , drawMorphingAt + -- ** Synchronizing multiple Evolutions + -- | 'EaseClock' can be used to synchronize multiple 'Evolution's. + , EaseClock(..) + , mkEaseClock + ) where + +import GHC.Show(showString) + +import Imj.Prelude + +import Control.Monad.IO.Class(MonadIO) +import Control.Monad.Reader.Class(MonadReader) + +import Imj.Graphics.Class.DiscreteInterpolation +import Imj.Graphics.Class.DiscreteMorphing +import Imj.Graphics.Math.Ease +import Imj.Iteration + +{-# INLINABLE mkEvolutionEaseQuart #-} +-- | An evolution between n 'DiscreteDistance's. With a 4th order ease in & out. +mkEvolutionEaseQuart :: DiscreteDistance v + => Successive v + -- ^ 'DiscreteDistance's through which the evolution will pass. + -> Float + -- ^ Duration in seconds + -> Evolution v +mkEvolutionEaseQuart = mkEvolution invQuartEaseInOut + +-- | An evolution between n 'DiscreteDistance's. With a user-specified (inverse) ease function. +{-# INLINABLE mkEvolution #-} +mkEvolution :: DiscreteDistance v + => (Float -> Float) + -- ^ Inverse continuous ease function + -> Successive v + -- ^ 'DiscreteDistance's through which the evolution will pass. + -> Float + -- ^ Duration in seconds + -> Evolution v +mkEvolution ease s duration = + let nSteps = distanceSuccessive s + lastFrame = Frame $ pred nSteps + in Evolution s lastFrame duration (discreteAdaptor ease nSteps) + +-- | Used to synchronize multiple 'Evolution's. +newtype EaseClock = EaseClock (Evolution NotWaypoint) deriving (Show) +newtype NotWaypoint = NotWaypoint () deriving(Show) + +-- | To make sure that we never use distance on an 'EaseClock'. +instance DiscreteDistance NotWaypoint where + distance = error "don't use distance on NotWaypoint" + +-- | Constructor of 'EaseClock' +mkEaseClock :: Float + -- ^ Duration in seconds + -> Frame + -- ^ Last frame + -> (Float -> Float) + -- ^ Inverse ease function (value -> time, both between 0 and 1) + -> EaseClock +mkEaseClock duration lastFrame ease = + let nSteps = fromIntegral $ succ lastFrame + in EaseClock $ Evolution (Successive []) lastFrame duration (discreteAdaptor ease nSteps) + +-- TODO we could optimize by precomputing the lastframes of each individual segment, +-- and select the interval without having to recompute every distance. +-- We could change the Successive type to store the cumulated distance, +-- then do a binary search +-- | Defines an evolution (interpolation or morphing) between 'Successive' 'DiscreteDistance's. +data Evolution v = Evolution { + _evolutionSuccessive :: !(Successive v) + -- ^ 'Successive' 'DiscreteDistance's. + , _evolutionLastFrame :: !Frame + -- ^ The frame at which the 'Evolution' value is equal to the last 'Successive' value. + , _evolutionDuration :: Float + -- ^ Duration of the interpolation in seconds. + , _evolutionInverseEase :: Float -> Float + -- ^ Inverse ease function. +} + +instance (Show v) => Show (Evolution v) where + showsPrec _ (Evolution a b c _) = showString $ "Evolution{" ++ show a ++ show b ++ show c ++ "}" + +-- | Computes the time increment between the input 'Frame' and the next. +getDeltaTimeToNextFrame :: Evolution v + -> Frame + -> Maybe Float + -- ^ If evolution is still ongoing, returns the time interval + -- between the input 'Frame' and the next. +getDeltaTimeToNextFrame (Evolution _ lastFrame@(Frame lastStep) duration easeValToTime) frame@(Frame step) + | frame < 0 = error "negative frame" + | frame >= lastFrame = Nothing + | otherwise = Just dt + where + nextStep = succ step + thisValue = fromIntegral step / fromIntegral lastStep + targetValue = fromIntegral nextStep / fromIntegral lastStep + dt = duration * (easeValToTime targetValue - easeValToTime thisValue) + + +{-# INLINABLE getValueAt #-} +-- | Gets the value of an 'Evolution' at a given 'Frame'. +getValueAt :: DiscreteInterpolation v + => Evolution v + -> Frame + -> v + -- ^ The evolution value. +getValueAt (Evolution s@(Successive l) lastFrame _ _) frame@(Frame step) + | frame <= 0 = head l + | frame >= lastFrame = last l + | otherwise = interpolateSuccessive s step + + +{-# INLINABLE drawMorphingAt #-} +-- | Draws an 'Evolution' at a given 'Frame'. +drawMorphingAt :: (DiscreteMorphing v, Draw e, MonadReader e m, MonadIO m) + => Evolution v + -> Frame + -> m () +drawMorphingAt (Evolution s _ _ _) (Frame step) = + drawMorphingSuccessive s $ assert (step >= 0) step diff --git a/src/Imj/Graphics/Interpolation/SequentiallyInterpolatedList.hs b/src/Imj/Graphics/Interpolation/SequentiallyInterpolatedList.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Graphics/Interpolation/SequentiallyInterpolatedList.hs @@ -0,0 +1,45 @@ +{-# OPTIONS_HADDOCK hide #-} + +{-# LANGUAGE NoImplicitPrelude #-} + +module Imj.Graphics.Interpolation.SequentiallyInterpolatedList( + SequentiallyInterpolatedList(..) + ) where + +import Imj.Prelude + +import Data.List(length, mapAccumL) + +import Imj.Graphics.Class.DiscreteInterpolation +import Imj.Util + +-- | A 'List'-like type to interpolate sequentially (one index at a time) between same-index elements. +newtype SequentiallyInterpolatedList a = + SequentiallyInterpolatedList [a] + deriving(Eq, Ord, Show) + +-- | Interpolation between 2 'SequentiallyInterpolatedList', occuring sequentially +-- i.e interpolating between one pair of same-index elements at a time, starting with +-- 0 index and increasing. +-- Prerequisite : lists have the same lengths. +instance (DiscreteDistance a) + => DiscreteDistance (SequentiallyInterpolatedList a) where + + distance (SequentiallyInterpolatedList l) (SequentiallyInterpolatedList l') = + succ $ sum $ zipWith (\x y -> pred $ distance x y) l (assert (length l' == length l) l') + +-- | Interpolation between 2 'SequentiallyInterpolatedList', occuring sequentially +-- i.e interpolating between one pair of same-index elements at a time, starting with +-- 0 index and increasing. +-- Prerequisite : lists have the same lengths. +instance (DiscreteInterpolation a) + => DiscreteInterpolation (SequentiallyInterpolatedList a) where + interpolate (SequentiallyInterpolatedList l) (SequentiallyInterpolatedList l') progress = + SequentiallyInterpolatedList $ snd $ + mapAccumL + (\acc (e,e') -> + let d = pred $ distance e e' + r = interpolate e e' $ clamp acc 0 d + in (acc-d, r)) + progress + $ zip l (assert (length l' == length l) l') diff --git a/src/Imj/Graphics/Math/Ease.hs b/src/Imj/Graphics/Math/Ease.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Graphics/Math/Ease.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Imj.Graphics.Math.Ease + ( + -- * 4th order /inverse/ easing, continuous + {- | Easing is traditionally seen as a function from /time/ to value. + + Here, it is a function from /value/ to time, hence the use of the term /Inverse/ in the title. + -} + invQuartEaseInOut + -- * From continuous to discrete + {- | + Easing in a continuous world is /easy/ (no pun intended), but easing in a + discrete world is harder : we have to make sure the discretization will + not break the visual easing effect. + + The 'discreteAdaptor' function does just that, making a continuous easing + function usable in a discrete context. + -} + , discreteAdaptor + -- * 4th order inverse easing, discrete + -- | Using 'discreteAdaptor' on 'invQuartEaseInOut' we can make + -- 'discreteInvQuartEaseInOut' : + , discreteInvQuartEaseInOut + ) where + +import Imj.Prelude + +-- cf. this for formatting : https://math.meta.stackexchange.com/questions/5020/mathjax-basic-tutorial-and-quick-reference + +{- | +Returns the time \( t \in [\,0,1]\, \) at which a value \( y \in [\,0,1]\,\) is reached +given a \( quartEaseInOut \): + +\[ y = quartEaseInOut(t) = +\begin{cases} +{1 \over 2} * (2*t)^4, & \;\;\;\; \text{if $t < {1 \over 2}$} \\[2ex] +-{1 \over 2} * \left( [ 2*(t-1) ]^4 - 2 \right), & \;\;\;\; \text{if $t > {1 \over 2}$} +\end{cases} +\] + +To find the formulas of 'invQuartEaseInOut', we need to invert \( quartEaseInOut \), +i.e. we need to express \(t\) in terms of \(y\): + +\[ \text{$quartEaseInOut$ is strictly increasing} \implies +\begin{cases} +t<{1 \over 2} \iff y<{1 \over 2} \\ +t>{1 \over 2} \iff y>{1 \over 2} +\end{cases} +\] + + +\[ \begin{alignedat}{3} +\text{if $y < {1 \over 2} $, given the $quartEaseInOut$ equation for $t < {1 \over 2} $ :} + && y &= {1 \over 2} * (2*t)^4 && \\ + \implies && \quad t &= \left({y \over 2^3}\right)^{1/4} && \quad \forall y < {1 \over 2} \\ +\text{if $y > {1 \over 2} $, given the $quartEaseInOut$ equation for $t > {1 \over 2} $ :} + && y &= - {1 \over 2} * \left( [2*(t-1)]^4 - 2 \right) && \\ + \implies && \quad t &= 1-\left[{1-y \over 2^3}\right]^{1/4} && \quad \forall y > {1 \over 2} +\end{alignedat} \] + +/Note that there are multiple solutions, we chose the ones that produce results in the \( [\,0,1]\, \) range./ + +Hence, the formulas for 'invQuartEaseInOut' are : + +\[ t = invQuartEaseInOut(y) = +\begin{cases} +\left({y \over 2^3}\right)^{1/4}, & \text{if $y < {1 \over 2}$} \\[2ex] +1-\left[{1-y \over 2^3}\right]^{1/4}, & \text{if $y > {1 \over 2}$} +\end{cases} +\] + + -} +invQuartEaseInOut :: Float + -- ^ Value : \( y \) + -> Float + -- ^ Time : \( t \) +invQuartEaseInOut y = + if y < 0.5 + then + (y / 8.0) ** (1.0/4.0) + else + 1.0 - ((1.0 - y) / 8.0) ** (1.0/4.0) + +-- | Adapts continuous inout ease functions to the discrete case. +discreteAdaptor :: (Float -> Float) + -- ^ Continuous (optionally inverse) ease in/out function + -> Int + -- ^ The number of discrete steps + -> Float + -- ^ Input value + -> Float + -- ^ (optionnaly inverse) Eased value +discreteAdaptor f n v = + -- We use the center of the intervals instead of the extremities. + let nIntervals = n + intervalSize = recip $ fromIntegral nIntervals + firstValue = intervalSize / 2 + lastValue = 1 - firstValue + scaledValue = firstValue + v * (lastValue - firstValue) + in f scaledValue + +-- | Returns the time (in range [0 1]) at which a value (in range [0 1]) is reached +-- given a 4th order ease in-out function, and a total number of discrete steps. +discreteInvQuartEaseInOut :: Int + -- ^ The number of discrete steps + -> Float + -- ^ Value + -> Float + -- ^ Time +discreteInvQuartEaseInOut = discreteAdaptor invQuartEaseInOut diff --git a/src/Imj/Graphics/Render.hs b/src/Imj/Graphics/Render.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Graphics/Render.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Imj.Graphics.Render + ( + -- * Draw and Render + {- | 'Draw' describes the ability to draw colored 'Char's, 'String's, 'Text's. + + 'Render' makes the result of draw*** calls visible on the screen. + + Optimized instances of 'Draw' and 'Render', for games and animations + drawing in the terminal, are + available in "Imj.Graphics.Render.Delta.Env". They minimize stdout usage using double + buffering and delta rendering, thereby mitigating the + . + -} + module Imj.Graphics.Class.Draw + , module Imj.Graphics.Class.Render + -- * From MonadReader +{- | The functions below use 'Draw' and 'Render' instances in a 'MonadReader' monad. + +Hence, if you run in a 'MonadReader' 'YourEnv' monad +(where 'YourEnv' is your environment equiped with 'Draw' and 'Render' instances), +you can write: + +@ +import Control.Monad.IO.Class(MonadIO) +import Control.Monad.Reader.Class(MonadReader) +import Control.Monad.Reader(runReaderT) + +import Imj.Graphics.Class.Render +import Imj.Graphics.Render.FromMonadReader(drawStr, renderToScreen) + +helloWorld :: (Draw e, Render e, MonadReader e m, MonadIO m) => m () +helloWorld = drawStr \"Hello World\" (Coords 10 10) green >> renderToScreen + +main = createEnv >>= runReaderT helloWorld +@ + + +follows this pattern. -} + , module Imj.Graphics.Render.FromMonadReader + -- * Reexports + , LayeredColor(..) + , Coords(..) + , Alignment(..) + , Text + , Char + , String + , MonadIO + , MonadReader + ) where + +import Imj.Prelude + +import Control.Monad.Reader.Class(MonadReader) +import Control.Monad.IO.Class(MonadIO) +import Data.Text(Text) + +import Imj.Graphics.Class.Draw +import Imj.Graphics.Class.Render +import Imj.Graphics.Render.FromMonadReader + +import Imj.Graphics.Color(LayeredColor(..)) +import Imj.Geo.Discrete(Coords(..)) +import Imj.Graphics.Text.Alignment(Alignment(..)) diff --git a/src/Imj/Graphics/Render/Delta.hs b/src/Imj/Graphics/Render/Delta.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Graphics/Render/Delta.hs @@ -0,0 +1,215 @@ +{-# OPTIONS_HADDOCK prune #-} + +{-# LANGUAGE NoImplicitPrelude #-} + +{-| +The purpose of this module is to render games and animations in the terminal +without . + +It supports +and characters. + +In short, +is mitigated by: + + * Using double buffering techniques (/back/ and /front/ buffers) + * Rendering in each frame /only/ the locations that have changed, in an order + that allows to omit many byte-expensive commands, + * Chosing the smallest rendering command among equivalent alternatives. + +A more detailed overview can be seen at the end of this documentation. +-} + +module Imj.Graphics.Render.Delta + ( -- * Usage +{- | +* from a 'MonadIO' monad (see +): + + @ + import Imj.Graphics.Class.Draw(drawStr') + import Imj.Graphics.Class.Render(renderToScreen') + + helloWorld :: (MonadIO m) => DeltaEnv -> m () + helloWorld env = do + drawStr' env \"Hello World\" (Coords 10 10) (onBlack green) + renderToScreen' env + + main = runThenRestoreConsoleSettings $ newDefaultEnv >>= helloWorld + @ + +* from a 'MonadIO', 'MonadReader' 'DeltaEnv' monad (see +): + + @ + import Imj.Graphics.Render.FromMonadReader(drawStr, renderToScreen) + + -- Note that we omit 'Draw e', which is implied by 'Render e': + helloWorld :: (Render e, MonadReader e m, MonadIO m) => m () + helloWorld = do + drawStr \"Hello World\" (Coords 10 10) (onBlack green) + renderToScreen + + main = runThenRestoreConsoleSettings $ newDefaultEnv >>= runReaderT helloWorld + @ + +* from a 'MonadIO', 'MonadReader' 'YourEnv' monad (see +): + + * assuming 'YourEnv' owns a 'DeltaEnv' and implements 'Draw' and 'Render' + instances forwarding to the 'Draw' and 'Render' instance of + the owned 'DeltaEnv': + + @ + import YourApp(createYourEnv) + import Imj.Graphics.Render.FromMonadReader(drawStr, renderToScreen) + + -- Note that we omit 'Draw e', which is implied by 'Render e': + helloWorld :: (Render e, MonadReader e m, MonadIO m) => m () + helloWorld = do + drawStr \"Hello World\" (Coords 10 10) (onBlack green) + renderToScreen + + main = runThenRestoreConsoleSettings $ newDefaultEnv >>= createYourEnv >>= runReaderT helloWorld + @ +-} + + -- * Environment + -- | Back and front buffers are persisted in the delta-rendering environment: + -- 'DeltaEnv'. + DeltaEnv + -- ** Environment creation +, newDefaultEnv +, newEnv +-- ** Policies +{- | Note that policy changes take effect after the next render. -} +-- *** Resize +, ResizePolicy(..) +, defaultResizePolicy +, setResizePolicy +-- *** Clear after render +, ClearPolicy(..) +, defaultClearPolicy +, setClearPolicy +, defaultClearColor +, setClearColor +-- ** Stdout BufferMode +{- When using 'setStdoutBufferMode', the stdout 'BufferMode' change is applied +immediately. -} +, defaultStdoutMode +, setStdoutBufferMode + -- * Draw and render + {- | The functions below present drawing and rendering functions in a 'MonadReader' + monad, which is the recommended way to use delta rendering. + + More alternatives are presented in this module: + -} +, module Imj.Graphics.Render +, module Imj.Graphics.Render.FromMonadReader + -- * Cleanup +, module Imj.Graphics.Render.Delta.Console +-- * Reexports +, BufferMode(..) + +-- * Motivations and technical overview +{- | + += Screen tearing + + occurs in the terminal +when, for a given frame, rendering commands exceed the capacity of stdout buffer. +To avoid overflowing stdout, the system flushes it, thereby triggering a /partial/ frame render. + += Motivations + +At the beginning of the development of +, +I was clearing the terminal screen at every frame and filling stdout with rendering commands +for every game element and animation. + +As the complexity of animations grew, screen tearing occured, so I looked for ways to fix it. +This package is the result of this research. + +My first idea to mitigate screen tearing was to maximize the size of stdout buffer: + +> hSetBuffering stdout $ BlockBuffering $ Just maxBound + +I developped @ imj-measure-stdout-exe @ to measure the size of stdout buffer and found +that the size had quadrupled, from 2048 to 8192 bytes. + +But it solved the problem only very temporarily. As I introduced more animations +in the game, screen tearing was back : I needed not only to maximize stdout size +but also to reduce the amount of data that I was writing in it. This is when I +discovered the /delta rendering/ approach. + +== Delta rendering + +Delta rendering is the approach + took when + for his own game. + +The idea was to introduce two in-memory buffers: + +* a /front/ buffer containing what is currently displayed on the terminal +* a /back/ buffer containing what we want to draw in the next frame. + +At every frame, we would draw all game elements and animations, +this time /not/ to the terminal directly, but to the back buffer. + +At the the end of the frame, the difference between front and back buffer would +be rendered to the terminal. + +== Further optimizations + +=== Minimizing the total size of rendering commands + +The initial implementation was fixing the screen tearing for my game, yet I wanted +to optimize things to be able to support even richer frame changes in the future. +I added the following optimizations: + +* We group locations by color before rendering them, to issue one @color change@ +per group instead of one per element (an 8-bit @color change@ command is 20 bytes: +@"\ESC[48;5;167;38;5;255m"@). + +* We render the "color group" elements by increasing screen positions, and when two +consecutive elements are found, we omit the @position change@ command, +because 'putChar' already moved the cursor position to the right (a 2-D +@position change@ command is 9 bytes: @"\ESC[150;42H"@). + +We can still improve on this by using a one-dimensional +@relative position change@ commands (3 to 6 bytes : @"\ESC[C"@, @"\ESC[183C"@) +when the next location is either on the same column or on the same line. + +=== Minimizing the run-time overhead and memory footprint + +I wanted not only to avoid screen tearing, but also to be fast, to allow for higher +framerates. So I refactored the datastructures to use continuous blocks of memory, +and to encode every important information in the smallest form possible, to improve cache usage. + + +helped in the process. + +I use Vectors of unpacked 'Word64' () +and an efficient encoding to stores 4 different informations in a Word64: + +/[from higher bits to lower bits]/ + + * background color (8 bits) + * foreground color (8 bits) + * buffer position (16 bits) + * unicode character (32 bits) + +I also introduced a third in-memory vector, the "Delta" vector, which contains just the differences to render. +Due to the previously described encoding, when +the delta vector, same-color locations end up being grouped in the same slice of the vector, +and are sorted by increasing position, which is exactly what we want to implement the optimizations I mentionned earlier. +-} + ) where + +-- TODO add a section on 'Performance documentation' to report on the amount of bytes +-- sent to stdout with concrete examples. + +import Imj.Graphics.Render +import Imj.Graphics.Render.Delta.Env +import Imj.Graphics.Render.Delta.Console +import Imj.Graphics.Render.FromMonadReader diff --git a/src/Imj/Graphics/Render/Delta/Buffers.hs b/src/Imj/Graphics/Render/Delta/Buffers.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Graphics/Render/Delta/Buffers.hs @@ -0,0 +1,86 @@ +{-# OPTIONS_HADDOCK hide #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Imj.Graphics.Render.Delta.Buffers + ( Buffers + , IORef + , newContext + -- utilities + , updateSize + ) where + +import Prelude hiding (replicate, unzip, length) + +import Data.IORef( IORef , newIORef , readIORef , writeIORef ) +import Data.Maybe( fromMaybe ) +import Data.Vector.Unboxed.Mutable( replicate, unzip, length ) + +import qualified Imj.Data.Vector.Unboxed.Mutable.Dynamic as Dyn (new) +import Imj.Graphics.Color.Types +import Imj.Graphics.Render.Delta.Types +import Imj.Graphics.Render.Delta.Internal.Types +import Imj.Graphics.Render.Delta.Buffers.Dimensions +import Imj.Graphics.Render.Delta.Cell +import Imj.Graphics.Render.Delta.Cells +import Imj.Graphics.Render.Delta.DefaultPolicies + + +-- we use IORef Buffers instead of Buffers because we want to update the size of the buffers +-- dynamically + +-- Creates a context using optional policies. +newContext :: Maybe ResizePolicy + -> Maybe ClearPolicy + -> Maybe (Color8 Background) + -> IO (IORef Buffers) +newContext mayResizePolicy mayClearPolicy mayClearColor = do + let resizePolicy = fromMaybe defaultResizePolicy mayResizePolicy + clearPolicy = fromMaybe defaultClearPolicy mayClearPolicy + clearColor = fromMaybe defaultClearColor mayClearColor + newContext' $ Policies resizePolicy clearPolicy clearColor + +newContext' :: Policies -> IO (IORef Buffers) +newContext' policies@(Policies resizePolicy _ _) = + getDimensions resizePolicy + >>= uncurry (createBuffers policies) + >>= newIORef + +-- | Creates buffers for given width and height, replaces 0 width or height by 1. +mkBuffers :: Dim Width + -> Dim Height + -> Cell + -> IO (Buffer Back, Buffer Front, Delta, Dim Width) +mkBuffers width' height' backBufferCell = do + let (sz, width) = bufferSizeFromWH width' height' + (bg, fg, char) = expand backBufferCell + -- We initialize to different colors to force a first render to the whole console. + frontBufferCell = mkCell (LayeredColor (succ bg) (succ fg)) (succ char) + buf <- newBufferArray sz (backBufferCell, frontBufferCell) + delta <- Dyn.new $ fromIntegral sz -- reserve the maximum possible size + let (back, front) = unzip buf + return (Buffer back, Buffer front, Delta delta, width) + +adjustSizeIfNeeded :: Buffers -> IO Buffers +adjustSizeIfNeeded buffers@(Buffers (Buffer back) _ prevWidth _ policies@(Policies resizePolicy _ _)) = do + (width, height) <- getDimensions resizePolicy + let prevSize = fromIntegral $ length back + prevHeight = getHeight prevWidth prevSize + if prevWidth /= width || prevHeight /= height + then + createBuffers policies width height + else + return buffers + +createBuffers :: Policies -> Dim Width -> Dim Height -> IO Buffers +createBuffers pol@(Policies _ _ clearColor) w h = do + (newBack, newFront, newDelta, newWidth) <- mkBuffers w h (clearCell clearColor) + -- no need to clear : we initialized with the right value + return $ Buffers newBack newFront newWidth newDelta pol + +updateSize :: IORef Buffers -> IO () +updateSize ref = + readIORef ref >>= adjustSizeIfNeeded >>= writeIORef ref + +-- TODO use phantom types for Cell (requires Data.Vector.Unboxed.Deriving to use newtype in vector) +newBufferArray :: Dim BufferSize -> (Cell, Cell) -> IO BackFrontBuffer +newBufferArray size = replicate (fromIntegral size) diff --git a/src/Imj/Graphics/Render/Delta/Buffers/Dimensions.hs b/src/Imj/Graphics/Render/Delta/Buffers/Dimensions.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Graphics/Render/Delta/Buffers/Dimensions.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_HADDOCK hide #-} + +module Imj.Graphics.Render.Delta.Buffers.Dimensions + ( getDimensions + , bufferSizeFromWH + ) where + +import Imj.Prelude + +import Data.Word( Word16, Word32 ) +import System.Console.Terminal.Size as Term (size, Window(..)) + +import Imj.Graphics.Render.Delta.Types + + +getDimensions :: ResizePolicy -> IO (Dim Width, Dim Height) +getDimensions (FixedSize w h) = + return (w,h) +getDimensions MatchTerminalSize = + maybe + (Dim 300, Dim 90) -- sensible default values in case we fail to get terminal size + (\(Term.Window h w) -> (Dim w, Dim h)) + <$> Term.size + + + +bufferSizeFromWH :: Dim Width -> Dim Height -> (Dim BufferSize, Dim Width) +bufferSizeFromWH (Dim w') (Dim h') = + let w = max 1 w' + h = max 1 h' + sz = fromIntegral w * fromIntegral h :: Word32 + -- indexed cells use a Word16 index so we can't exceed the Word16 maxBound + in if sz > fromIntegral (maxBound :: Word16) + then + error $ "buffer size cannot be bigger than " ++ show (maxBound :: Word16) ++ + " : " ++ show (sz, w, h) + else + (Dim $ fromIntegral sz, Dim w) diff --git a/src/Imj/Graphics/Render/Delta/Cell.hs b/src/Imj/Graphics/Render/Delta/Cell.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Graphics/Render/Delta/Cell.hs @@ -0,0 +1,93 @@ +{-# OPTIONS_HADDOCK hide #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Imj.Graphics.Render.Delta.Cell + ( Cell + , mkCell + -- ** Indexed cells + , mkIndexedCell + , expandIndexed + , getIndex + , expand + ) where + +import Imj.Prelude + +import Data.Bits(shiftL, shiftR, (.&.), (.|.)) +import Data.Char( chr, ord ) +import Data.Word( Word64, Word32, Word16, Word8 ) + +import Imj.Graphics.Color.Types +import Imj.Graphics.Render.Delta.Internal.Types +import Imj.Graphics.Render.Delta.Types + + +{-# INLINE firstWord8 #-} +firstWord8 :: Word64 -> Word8 +firstWord8 w = fromIntegral $ w `shiftR` 56 + +{-# INLINE secondWord8 #-} +secondWord8 :: Word64 -> Word8 +secondWord8 w = fromIntegral $ (w `shiftR` 48) .&. 0xFF + +{-# INLINE secondWord16 #-} +secondWord16 :: Word64 -> Word16 +secondWord16 w = fromIntegral $ (w `shiftR` 32) .&. 0xFFFF + +{-# INLINE secondWord32 #-} +secondWord32 :: Word64 -> Word32 +secondWord32 = fromIntegral + +{-# INLINE getForegroundColor #-} +getForegroundColor :: Cell -> Color8 Foreground +getForegroundColor w = mkColor8 $ secondWord8 w + +{-# INLINE getBackgroundColor #-} +getBackgroundColor :: Cell -> Color8 Background +getBackgroundColor w = mkColor8 $ firstWord8 w + +{-# INLINE getCharacter #-} +getCharacter :: Cell -> Char +getCharacter w = chr $ fromIntegral $ secondWord32 w + +-- Works only if the 'Cell' was created using mkIndexedCell, +-- else 0 is returned. +{-# INLINE getIndex #-} +getIndex :: Cell -> Dim BufferIndex +getIndex w = fromIntegral $ secondWord16 w + +{-# INLINE expand #-} +expand :: Cell + -> (Color8 Background, Color8 Foreground, Char) +expand w = (getBackgroundColor w + ,getForegroundColor w + ,getCharacter w) + +{-# INLINE expandIndexed #-} +expandIndexed :: Cell + -> (Color8 Background, Color8 Foreground, Dim BufferIndex, Char) +expandIndexed w = + (getBackgroundColor w + ,getForegroundColor w + ,getIndex w + ,getCharacter w) + +-- The memory layout is such that when sorted with 'compare', the order of +-- importance of fields is (by decreasing importance) : +-- backgroundColor (8 bits) +-- foregroundColor (8 bits) +-- index in buffer (16 bits) +-- character (32 bits) +{-# INLINE mkIndexedCell #-} +mkIndexedCell :: Cell -> Dim BufferIndex -> Cell +mkIndexedCell cell idx' = + cell .|. (idx `shiftL` 32) + where + idx = fromIntegral idx' + +{-# INLINE mkCell #-} +mkCell :: LayeredColor -> Char -> Cell +mkCell colors char' = + let color = fromIntegral $ encodeColors colors + char = fromIntegral $ ord char' + in (color `shiftL` 48) .|. char diff --git a/src/Imj/Graphics/Render/Delta/Cells.hs b/src/Imj/Graphics/Render/Delta/Cells.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Graphics/Render/Delta/Cells.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_HADDOCK hide #-} + +module Imj.Graphics.Render.Delta.Cells + (clearCell + ) where + +import Imj.Graphics.Color +import Imj.Graphics.Render.Delta.Internal.Types +import Imj.Graphics.Render.Delta.Cell + +clearCell :: Color8 Background -> Cell +clearCell clearColor = + -- Any foreground color would be ok + mkCell (LayeredColor clearColor white) ' ' diff --git a/src/Imj/Graphics/Render/Delta/Clear.hs b/src/Imj/Graphics/Render/Delta/Clear.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Graphics/Render/Delta/Clear.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_HADDOCK hide #-} + +module Imj.Graphics.Render.Delta.Clear + ( clearIfNeeded + ) where + +import Imj.Prelude + +import Control.Monad(when) + +import Imj.Graphics.Render.Delta.Internal.Types +import Imj.Graphics.Render.Delta.Types +import Imj.Graphics.Render.Delta.Cells +import Imj.Graphics.Render.Delta.Draw + +clearIfNeeded :: ClearContext -> Buffers -> IO () +clearIfNeeded context b@(Buffers _ _ _ _ (Policies _ clearPolicy clearColor)) = + when (clearPolicy == ClearAtEveryFrame || context == OnAllocation) $ + fillBackBuffer b (clearCell clearColor) diff --git a/src/Imj/Graphics/Render/Delta/Console.hs b/src/Imj/Graphics/Render/Delta/Console.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Graphics/Render/Delta/Console.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_HADDOCK hide #-} + +module Imj.Graphics.Render.Delta.Console + ( ConsoleConfig(..) + , configureConsoleFor + , restoreConsoleSettings + , runThenRestoreConsoleSettings + ) where + +import Imj.Prelude + +import Control.Exception( finally ) + +import System.Console.Terminal.Size( size , Window(..)) +import System.Console.ANSI( clearScreen, hideCursor + , setSGR, setCursorPosition, showCursor ) +import System.IO( hSetBuffering + , hGetBuffering + , hSetEcho + , BufferMode( .. ) + , stdin + , stdout ) + + +data ConsoleConfig = Gaming | Editing + +configureConsoleFor :: ConsoleConfig -> BufferMode -> IO () +configureConsoleFor config stdoutMode = + hSetBuffering stdout stdoutMode >> + case config of + Gaming -> do + hSetEcho stdin False + hideCursor + clearScreen -- do not clearFromCursorToScreenEnd with 0 0, so as to keep + -- the current console content above the game. + let requiredInputBuffering = NoBuffering + initialIb <- hGetBuffering stdin + hSetBuffering stdin requiredInputBuffering + ib <- hGetBuffering stdin + when (ib /= requiredInputBuffering) $ + error $ "input buffering mode " + ++ show initialIb + ++ " could not be changed to " + ++ show requiredInputBuffering + ++ " instead it is now " + ++ show ib + Editing -> do + hSetEcho stdin True + showCursor + -- do not clearFromCursorToScreenEnd, to retain a potential printed exception + setSGR [] + size >>= maybe (return ()) (\(Window x _) -> setCursorPosition (pred x) 0) + hSetBuffering stdout LineBuffering + + +-- Restores stdin, stdout bufferings, unhides the cursor, restores echo for +-- stdin, restores the buffering of stdout to 'LineBuffering' +restoreConsoleSettings :: IO () +restoreConsoleSettings = + configureConsoleFor Editing LineBuffering + +-- | Helper function to run an action and restore the console settings when it +-- is finished or when an exception was thrown. +runThenRestoreConsoleSettings :: IO a -> IO a +runThenRestoreConsoleSettings action = + -- When Ctrl+C is hit, an exception is thrown on the main thread, hence + -- I use 'finally' to reset the console settings. + action `finally` restoreConsoleSettings diff --git a/src/Imj/Graphics/Render/Delta/DefaultPolicies.hs b/src/Imj/Graphics/Render/Delta/DefaultPolicies.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Graphics/Render/Delta/DefaultPolicies.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_HADDOCK hide #-} + +-- | This module defines the default policies. + +module Imj.Graphics.Render.Delta.DefaultPolicies + where + +import Imj.Prelude + +import System.IO(BufferMode(..)) + +import Imj.Graphics.Color +import Imj.Graphics.Render.Delta.Types + + +-- | @=@ 'MatchTerminalSize' +defaultResizePolicy :: ResizePolicy +defaultResizePolicy = MatchTerminalSize + +-- | @=@ 'ClearAtEveryFrame' +defaultClearPolicy :: ClearPolicy +defaultClearPolicy = ClearAtEveryFrame + +-- | @=@ 'black' +defaultClearColor :: Color8 Background +defaultClearColor = black + +-- | @=@ 'BlockBuffering' $ 'Just' 'maxBound' +defaultStdoutMode :: BufferMode +defaultStdoutMode = + BlockBuffering $ Just maxBound -- maximize the buffer size to avoid screen tearing diff --git a/src/Imj/Graphics/Render/Delta/Draw.hs b/src/Imj/Graphics/Render/Delta/Draw.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Graphics/Render/Delta/Draw.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_HADDOCK hide #-} + +module Imj.Graphics.Render.Delta.Draw + ( fill + , deltaDrawChar + , deltaDrawChars + , deltaDrawStr + , deltaDrawTxt + , module Imj.Graphics.Color + , module Imj.Geo.Discrete.Types + , String + -- utilities + , fillBackBuffer + ) where + +import Imj.Prelude + +import Data.IORef( IORef , readIORef ) +import Data.Text(Text, unpack) +import Data.Vector.Unboxed.Mutable( write, set, length ) + +import Imj.Geo.Discrete +import Imj.Geo.Discrete.Types +import Imj.Graphics.Color +import Imj.Graphics.Render.Delta.Internal.Types +import Imj.Graphics.Render.Delta.Types +import Imj.Graphics.Render.Delta.Cell + + +{-# INLINABLE deltaDrawChar #-} +-- | Draw a 'Char' +deltaDrawChar :: IORef Buffers + -> Char + -> Coords Pos + -- ^ Location + -> LayeredColor + -- ^ Background and foreground colors + -> IO () +deltaDrawChar ref c pos colors = + readIORef ref + >>= \(Buffers back@(Buffer b) _ width _ _) -> do + let size = fromIntegral $ length b + writeToBack back (indexFromPos size width pos) (mkCell colors c) + + +{-# INLINABLE deltaDrawChars #-} +-- | Draws a 'Char' multiple times, starting at the given coordinates and then moving to the right. +-- +-- @deltaDrawChars n c@ should be faster than @deltaDrawStr (repeat n c)@, +-- as the encoding of information in a 'Cell' happens once only. (TODO verify in GHC core with optimizations) +deltaDrawChars :: IORef Buffers + -> Int + -- ^ Number of chars to draw + -> Char + -> Coords Pos + -- ^ Location of left-most 'Char' + -> LayeredColor + -- ^ Background and foreground colors + -> IO () +deltaDrawChars ref count c pos colors = + readIORef ref + >>= \(Buffers back@(Buffer b) _ width _ _) -> do + let cell = mkCell colors c + size = fromIntegral $ length b + mapM_ + (\i -> writeToBack back (indexFromPos size width (move i RIGHT pos)) cell) + [0..pred count] + + +{-# INLINABLE deltaDrawStr #-} +-- | Draw a 'String' +deltaDrawStr :: IORef Buffers + -> String + -> Coords Pos + -- ^ Location of first 'Char' + -> LayeredColor + -- ^ Background and foreground colors + -> IO () +deltaDrawStr ref str pos colors = + readIORef ref + >>= \(Buffers back@(Buffer b) _ width _ _) -> do + let size = fromIntegral $ length b + mapM_ + (\(c, i) -> + writeToBack back (indexFromPos size width (move i RIGHT pos)) (mkCell colors c)) + $ zip str [0..] + +{-# INLINABLE deltaDrawTxt #-} +-- | Draw a 'Text' +deltaDrawTxt :: IORef Buffers + -> Text + -> Coords Pos + -- ^ Location of first 'Char' + -> LayeredColor + -- ^ Background and foreground colors + -> IO () +deltaDrawTxt ref text = deltaDrawStr ref $ unpack text + + +{-# INLINE writeToBack #-} +writeToBack :: Buffer Back -> Maybe (Dim BufferIndex) -> Cell -> IO () +writeToBack _ Nothing _ = return () +writeToBack (Buffer b) (Just pos) cell = + write b (fromIntegral pos) cell + + +-- | Fills the entire area with a colored char. +fill :: Char + -> LayeredColor + -> IORef Buffers + -> IO () +fill char colors ioRefBuffers = + readIORef ioRefBuffers + >>= flip fillBackBuffer (mkCell colors char) + + +fillBackBuffer :: Buffers + -> Cell + -> IO () +fillBackBuffer (Buffers (Buffer b) _ _ _ _) = + set b + + +{-# INLINE indexFromPos #-} +indexFromPos :: Dim Size -> Dim Width -> Coords Pos -> Maybe (Dim BufferIndex) +indexFromPos size width (Coords y x) = + if x >= fromIntegral width + then Nothing + else + let idx = fromIntegral y * fromIntegral width + fromIntegral x + in if idx < size + then Just $ fromIntegral idx + else Nothing diff --git a/src/Imj/Graphics/Render/Delta/Env.hs b/src/Imj/Graphics/Render/Delta/Env.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Graphics/Render/Delta/Env.hs @@ -0,0 +1,117 @@ +{-# OPTIONS_HADDOCK hide #-} + +{-# LANGUAGE NoImplicitPrelude #-} + + +module Imj.Graphics.Render.Delta.Env + ( DeltaEnv + , newDefaultEnv + , newEnv + , ResizePolicy(..) + , defaultResizePolicy + , setResizePolicy + , ClearPolicy(..) + , defaultClearPolicy + , setClearPolicy + , defaultClearColor + , setClearColor + , defaultStdoutMode + , setStdoutBufferMode + -- * Reexports + , BufferMode(..) + ) where + +import Imj.Prelude + +import System.IO(BufferMode(..), hSetBuffering, stdout) + +import Control.Monad.IO.Class(liftIO) + +import Data.IORef( IORef, readIORef, writeIORef ) +import Data.Maybe( fromMaybe ) + +import Imj.Graphics.Class.Draw +import Imj.Graphics.Class.Render +import Imj.Graphics.Render.Delta.Buffers +import Imj.Graphics.Render.Delta.Console +import Imj.Graphics.Render.Delta.DefaultPolicies +import Imj.Graphics.Render.Delta.Draw +import Imj.Graphics.Render.Delta.Flush +import Imj.Graphics.Render.Delta.Types + +newtype DeltaEnv = DeltaEnv (IORef Buffers) + +-- | Draws using the delta rendering engine. +instance Draw DeltaEnv where + drawChar' (DeltaEnv a) b c d = liftIO $ deltaDrawChar a b c d + drawChars' (DeltaEnv a) b c d e = liftIO $ deltaDrawChars a b c d e + drawTxt' (DeltaEnv a) b c d = liftIO $ deltaDrawTxt a b c d + drawStr' (DeltaEnv a) b c d = liftIO $ deltaDrawStr a b c d + {-# INLINABLE drawChar' #-} + {-# INLINABLE drawChars' #-} + {-# INLINABLE drawTxt' #-} + {-# INLINABLE drawStr' #-} +-- | Renders using the delta rendering engine. +instance Render DeltaEnv where + renderToScreen' (DeltaEnv a) = liftIO $ deltaFlush a + {-# INLINABLE renderToScreen' #-} + + +-- | Creates an environment using default policies. +newDefaultEnv :: IO DeltaEnv +newDefaultEnv = newEnv Nothing Nothing Nothing Nothing + +-- | Creates an environment with policies. +newEnv :: Maybe ResizePolicy + -> Maybe ClearPolicy + -> Maybe (Color8 Background) + -> Maybe BufferMode + -- ^ Preferred stdout 'BufferMode'. + -> IO DeltaEnv +newEnv a b c mayBufferMode = do + let stdoutBufMode = fromMaybe defaultStdoutMode mayBufferMode + configureConsoleFor Gaming stdoutBufMode + DeltaEnv <$> newContext a b c + + +-- | Sets the 'ResizePolicy' for back and front buffers. +-- Defaults to 'defaultResizePolicy' when Nothing is passed. +setResizePolicy :: Maybe ResizePolicy + -> DeltaEnv + -> IO () +setResizePolicy mayResizePolicy (DeltaEnv ref) = + readIORef ref + >>= \(Buffers a b d e (Policies _ f g)) -> do + let resizePolicy = fromMaybe defaultResizePolicy mayResizePolicy + writeIORef ref $ Buffers a b d e (Policies resizePolicy f g) + + +-- | Sets the 'ClearPolicy'. +-- | Defaults to 'defaultClearPolicy' when Nothing is passed. +setClearPolicy :: Maybe ClearPolicy + -> DeltaEnv + -> IO () +setClearPolicy mayClearPolicy (DeltaEnv ref) = + readIORef ref + >>= \(Buffers a b d e (Policies f _ clearColor)) -> do + let clearPolicy = fromMaybe defaultClearPolicy mayClearPolicy + buffers = Buffers a b d e (Policies f clearPolicy clearColor) + writeIORef ref buffers + +-- | Sets the 'Color8' to use when clearing. +-- Defaults to 'defaultClearColor' when Nothing is passed. +setClearColor :: Maybe (Color8 Background) + -> DeltaEnv + -> IO () +setClearColor mayClearColor (DeltaEnv ref) = + readIORef ref + >>= \(Buffers a b d e (Policies f clearPolicy _)) -> do + let clearColor = fromMaybe defaultClearColor mayClearColor + buffers = Buffers a b d e (Policies f clearPolicy clearColor) + writeIORef ref buffers + +-- | Sets stdout's 'BufferMode'. Defaults to 'defaultStdoutMode' when Nothing is passed. +setStdoutBufferMode :: Maybe BufferMode + -> IO () +setStdoutBufferMode mayBufferMode = + hSetBuffering stdout (fromMaybe defaultStdoutMode mayBufferMode) diff --git a/src/Imj/Graphics/Render/Delta/Flush.hs b/src/Imj/Graphics/Render/Delta/Flush.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Graphics/Render/Delta/Flush.hs @@ -0,0 +1,235 @@ +{-# OPTIONS_HADDOCK hide #-} + +{-# LANGUAGE NoImplicitPrelude #-} + +module Imj.Graphics.Render.Delta.Flush + ( deltaFlush + ) where + +import Imj.Prelude + +import qualified Prelude(putStr, putChar) + +import Control.Monad(when) +import Data.IORef( IORef , readIORef ) +import Data.Vector.Unboxed.Mutable( IOVector, read, write, length ) +import System.IO( stdout, hFlush ) + +import qualified Imj.Data.Vector.Unboxed.Mutable.Dynamic as Dyn + (unstableSort, accessUnderlying, length, + clear, pushBack ) +import Imj.Graphics.Color.Types +import Imj.Graphics.Render.Delta.Types +import Imj.Graphics.Render.Delta.Buffers +import Imj.Graphics.Render.Delta.Cell +import Imj.Graphics.Render.Delta.Clear +import Imj.Graphics.Render.Delta.Internal.Types + + +-- | Flushes the frame, i.e renders it to the console. +-- Then, resizes the context if needed (see 'ResizePolicy') +-- and clears the back buffer (see 'ClearPolicy'). +deltaFlush :: IORef Buffers -> IO () +deltaFlush ioRefBuffers = + readIORef ioRefBuffers + >>= + render + >> do + updateSize ioRefBuffers + -- TODO if buffers resized because the terminal resized, send a clearScreen command or re-render with new size + hFlush stdout -- TODO is flush blocking? slow? could it be async? + + +render :: Buffers -> IO () +render buffers@(Buffers _ _ width (Delta delta) _) = do + computeDelta buffers 0 + + clearIfNeeded OnFrame buffers + + -- On average, foreground and background color change command is 20 bytes : + -- "\ESC[48;5;167;38;5;255m" + -- On average, position change command is 9 bytes : + -- "\ESC[150;42H" + -- So we want to minimize the number of color changes first, and then mimnimize + -- the number of position changes. + -- In 'Cell', color is encoded in higher bits than position, so this sort + -- sorts by color first, then by position, which is what we want. + Dyn.unstableSort delta + + szDelta <- Dyn.length delta + under <- Dyn.accessUnderlying delta + -- We ignore this color value. We could store it and use it to initiate the recursion + -- at next render but if the client renders with another library in-betweeen, this value + -- would be wrong, so we can ignore it here for more robustness. + _ <- renderDelta under (fromIntegral szDelta) width 0 Nothing Nothing + Dyn.clear delta + +-- We pass the underlying vector, and the size instead of the dynamicVector +renderDelta :: IOVector Cell + -> Dim BufferSize + -> Dim Width + -> Dim BufferIndex + -> Maybe LayeredColor + -> Maybe (Dim BufferIndex) + -> IO LayeredColor +renderDelta delta size width index prevColors prevIndex + | fromIntegral size == index = + return whiteOnBlack -- the value is not used + | otherwise = do + c <- read delta $ fromIntegral index + let (bg, fg, idx, char) = expandIndexed c + prevRendered = (== Just (pred idx)) prevIndex + setCursorPositionIfNeeded width idx prevRendered + usedColor <- renderCell bg fg char prevColors + renderDelta delta size width (succ index) (Just usedColor) (Just idx) + + +computeDelta :: Buffers + -> Dim BufferIndex + -- ^ the buffer index + -> IO () +computeDelta + b@(Buffers (Buffer backBuf) (Buffer frontBuf) _ (Delta delta) _) + idx + | fromIntegral idx == size = return () + | otherwise = do + let i = fromIntegral idx + -- read from back buffer + valueToDisplay <- read backBuf i + -- read from front buffer + valueCurrentlyDisplayed <- read frontBuf i + -- if differences are found, update front buffer and push the difference + -- in delta vector + when (valueToDisplay /= valueCurrentlyDisplayed) $ do + write frontBuf i valueToDisplay + Dyn.pushBack delta $ mkIndexedCell valueToDisplay idx + -- recurse + computeDelta b (succ idx) + where + size = length backBuf + +-- TODO merge with color change command to save 2 bytes +-- | The command to set the cursor position to 123,45 is "\ESC[123;45H", +-- its size is 9 bytes : one order of magnitude more than the size +-- of a char, so we avoid sending this command when not strictly needed. +{-# INLINE setCursorPositionIfNeeded #-} +setCursorPositionIfNeeded :: Dim Width + -> Dim BufferIndex + -- ^ the buffer index + -> Bool + -- ^ True if a char was rendered at the previous buffer index + -> IO () +setCursorPositionIfNeeded width idx predPosRendered = do + let (colIdx, rowIdx) = xyFromIndex width idx + shouldSetCursorPosition = + -- We assume that the buffer width is not equal to terminal width, + -- so even if the previous position was rendered, + -- the cursor may not be located at the beginning of the line. + colIdx == 0 + -- If the previous buffer position was rendered, the cursor position has + -- automatically advanced to the next column (or to the beginning of + -- the next line if it was the last terminal column). + || not predPosRendered + when shouldSetCursorPosition $ Prelude.putStr $ setCursorPositionCode (fromIntegral rowIdx) (fromIntegral colIdx) + +setCursorPositionCode :: Int -- ^ 0-based row to move to + -> Int -- ^ 0-based column to move to + -> String +setCursorPositionCode n m = csi [n + 1, m + 1] "H" + +{-# INLINE renderCell #-} +renderCell :: Color8 Background + -> Color8 Foreground + -> Char + -> Maybe LayeredColor + -> IO LayeredColor +renderCell bg fg char maybeCurrentConsoleColor = do + let (bgChange, fgChange, usedFg) = + maybe + (True, True, fg) + (\(LayeredColor bg' fg') -> + -- use foreground color if we don't draw a space + let useFg = char /= ' ' -- I don't use Data.Char.isSpace, it could be slower + usedFg' = if useFg + then + fg + else + fg' + in (bg'/=bg, fg'/=usedFg', usedFg')) + maybeCurrentConsoleColor + sgrs = concat $ [color8FgSGRToCode fg | fgChange] ++ + [color8BgSGRToCode bg | bgChange] + + if bgChange || fgChange + then + Prelude.putStr $ csi sgrs "m" ++ [char] + else + Prelude.putChar char + return $ LayeredColor bg usedFg + + +csi :: [Int] + -> String + -> String +csi args code = "\ESC[" ++ intercalate ";" (map show args) ++ code + + +{-# INLINE xyFromIndex #-} +xyFromIndex :: Dim Width -> Dim BufferIndex -> (Dim Col, Dim Row) +xyFromIndex width idx = + getRowCol idx width + +-- TODO use this formalism +{- +newtype SetPosition = Move2d !Int !Int + | Move1 Direction !Int + +type Value = (Color8 Background, Color8 Foreground, Char) +type Location = (Row, Column) + +screenLocations = { (row, column) | row <- [0..screenHeight], column <- [0..screenWidth] } + +type Step = Int -- represents a temporal game / animation step + +frame :: Step -> Location -> Value -- defines the desired content of animations + +identicalLocations n = {loc | loc <- screenLocations && frame n loc == frame (pred n) loc} +deltaLocations n = screenLocations \\ (identicalLocations n) + +newtype RenderCmd = SetPosition | SetColor | Char | !String +newtype SetPosition = Move2d Int Int | Move Direction Int +newtype SetColor = SetColorForeground | SetColorBackground | SetColorBoth +newtype Direction = Up | Left | Down | Right + +cheapestChangePosition' :: (Row,Col) -> SetPosition +cheapestChangePosition :: (Row,Col) -> (Row,Col) -> Maybe SetPosition + +cheapestChangeColor' :: (Background Color, Foreground Color) -> SetColor +cheapestChangeColor :: (Background Color, Foreground Color) -> (Background Color, Foreground Color) -> Maybe SetColor + +cost :: RenderCmd -> Int -- the cost is in bytes + +render :: [(Location,Value)] -> IO () +render l = do + let cmds = cheapestCmds l + str = concatMap asString cmds + printStr str + hFlush stdout + +cheapestCmds :: [(Location,Value)] -> [RenderCmd] +cheapestCmds [] = [] +cheapestCmds l = + let l' = sortDelta l + in renderFirst (head l') ++ cheapestCmds' l' + +cheapestCmds' :: [(Location,Value)] -> [RenderCmd] +cheapestCmds' [] = error "" +cheapestCmds' [a] = [] +cheapestCmds' l@(a:b:_) = renderNext a b ++ cheapestCmds' (tail l) + +sortDelta :: [(Location,Value)] -> [(Location,Value)] +sortDelta = sortByColorThenIncreasingLocation + +renderFirst :: (Location, Value) -> RenderCmd +renderNext :: (Location,Value) -> (Location,Value) -> RenderCmd -- Choses the best command (the cheapest one) when there are multiple possibilities. +-} diff --git a/src/Imj/Graphics/Render/Delta/Internal/Types.hs b/src/Imj/Graphics/Render/Delta/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Graphics/Render/Delta/Internal/Types.hs @@ -0,0 +1,38 @@ +{-# OPTIONS_HADDOCK hide #-} + +module Imj.Graphics.Render.Delta.Internal.Types + ( BackFrontBuffer + , Buffer(..) + , Back + , Front + , Delta(..) + , Cell + , ClearContext(..) + -- * Reexports + , IORef + ) where + +import Data.IORef( IORef ) + +import Data.Word( Word64 ) +import Data.Vector.Unboxed.Mutable( IOVector ) + +import qualified Imj.Data.Vector.Unboxed.Mutable.Dynamic as Dyn( IOVector ) + +-- | Buffer types +data Back +data Front + +type BackFrontBuffer = IOVector (Cell, Cell) + +newtype Buffer a = Buffer (IOVector Cell) + +newtype Delta = Delta (Dyn.IOVector Cell) + +data ClearContext = OnAllocation + | OnFrame + deriving(Eq, Show) + +-- Word64 is optimal: there is no wasted space when unboxed, +-- cf. https://wiki.haskell.org/GHC/Memory_Footprint +type Cell = Word64 diff --git a/src/Imj/Graphics/Render/Delta/Types.hs b/src/Imj/Graphics/Render/Delta/Types.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Graphics/Render/Delta/Types.hs @@ -0,0 +1,103 @@ +{-# OPTIONS_HADDOCK hide #-} + +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Imj.Graphics.Render.Delta.Types + ( + -- * Buffers + Buffers(..) + -- ** Policies + , Policies(..) + , ResizePolicy(..) + , ClearPolicy(..) + , Dim(..) + , BufferSize + , BufferIndex + , getRowCol + , getHeight + -- ** Reexported types + , Word16 + , Height + , Width + , Row + , Col + , IORef + , Color8 + ) where + +import Imj.Prelude + +import Control.Exception(assert) + +import Data.IORef(IORef) +import Data.Word(Word16) + +import Imj.Geo.Discrete.Types(Width, Height, Row, Col) +import Imj.Graphics.Color.Types +import Imj.Graphics.Render.Delta.Internal.Types + +-- | When and how to resize buffers. +data ResizePolicy = MatchTerminalSize + -- ^ After each render, buffers are resized (if needed) to match + -- terminal size. + | FixedSize !(Dim Width) !(Dim Height) + -- ^ Buffers have a fixed size. If they are vertically + -- or horizontally bigger than the terminal, rendering + -- artefacts will be visible. + deriving(Show, Eq) + +-- TODO allow to specify alignment constraints vs terminal : +-- horizontally = right-align | left-align | center +-- vertically = top-align | bottom-align | center +-- +-- TODO allow to specify sizes in terminal percentage: + +-- | Specifies /when/ to clear the back-buffer. +data ClearPolicy = ClearAtEveryFrame + -- ^ Clears the back-buffer after allocation + -- and after each frame render. + | ClearOnAllocationOnly + -- ^ Clears the back-buffer after allocation only. + -- Typically, you will use it if at every frame you draw at every screen location. + -- If you don't redraw every screen location at every frame, it is safer + -- to use 'ClearAtEveryFrame', else you will see previous frame elements + -- in the rendered frame (unless you intend to have this behaviour). + deriving(Show, Eq) + +newtype Dim a = Dim Word16 deriving(Num, Eq, Ord, Show, Real, Enum, Integral) + +-- | Buffer size (width * height) +data BufferSize +-- | Buffer element index +data BufferIndex + +{-# INLINE getHeight #-} +getHeight :: Dim Width -> Dim BufferSize -> Dim Height +getHeight (Dim w) (Dim sz) = + let h = quot sz w + in Dim $ assert (h * w == sz) h + +{-# INLINE getRowCol #-} +getRowCol :: Dim BufferIndex -> Dim Width -> (Dim Col, Dim Row) +getRowCol (Dim idx) (Dim w) = + (Dim x, Dim y) + where + y = idx `div` w + x = idx - y * w + + +data Buffers = Buffers { + _renderStateBackBuffer :: !(Buffer Back) + , _renderStateFrontBuffer :: !(Buffer Front) + , _buffersDrawWidth :: !(Dim Width) -- The size is stored in back and front buffers + , _buffersDelta :: !Delta + -- ^ The delta-buffer is used in renderFrame + , _buffersPolicies :: !Policies +} + +data Policies = Policies { + _policiesResizePolicy :: !ResizePolicy + , _policiesClearPolicy :: !ClearPolicy + , _policiesClearColor :: !(Color8 Background) +} deriving(Show) diff --git a/src/Imj/Graphics/Render/FromMonadReader.hs b/src/Imj/Graphics/Render/FromMonadReader.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Graphics/Render/FromMonadReader.hs @@ -0,0 +1,127 @@ +{-# OPTIONS_HADDOCK hide #-} + +{-# LANGUAGE NoImplicitPrelude #-} + +module Imj.Graphics.Render.FromMonadReader + ( + -- ** Draw char(s) + drawChar + , drawChars + -- ** Draw text + , drawTxt + , drawStr + , drawColorStr + -- ** Draw aligned text + , drawAlignedTxt_ + , drawAlignedTxt + , drawAlignedColorStr + -- ** Render to the physical device + , renderToScreen + ) where + +import Imj.Prelude + +import Control.Monad(join) +import Control.Monad.IO.Class(MonadIO) +import Control.Monad.Reader.Class(MonadReader, asks) +import Data.Text(Text) + +import Imj.Geo.Discrete.Types +import Imj.Graphics.Class.Draw +import Imj.Graphics.Class.Render +import Imj.Graphics.Color(LayeredColor(..)) +import Imj.Graphics.Text.Alignment +import Imj.Graphics.Text.ColorString + + +-- | Draw a 'ColorString'. +{-# INLINABLE drawColorStr #-} +drawColorStr :: (Draw e, MonadReader e m, MonadIO m) + => ColorString -> Coords Pos -> m () +drawColorStr cs pos = do + d <- asks drawColorStr' + d cs pos + +-- | Draw a 'ColorString' with an 'Alignment' constraint. +{-# INLINABLE drawAlignedColorStr #-} +drawAlignedColorStr :: (Draw e, MonadReader e m, MonadIO m) + => Alignment -> ColorString -> m Alignment +drawAlignedColorStr a cs = do + d <- asks drawAlignedColorStr' + d a cs + +-- | Draws text with 'Alignment'. +{-# INLINABLE drawAlignedTxt_ #-} +drawAlignedTxt_ :: (Draw e, MonadReader e m, MonadIO m) + => Text + -> LayeredColor + -> Alignment + -> m () +drawAlignedTxt_ txt colors a = do + d <- asks drawAlignedTxt_' + d txt colors a + +-- | Draws text with 'Alignment'. +-- +-- Returns the 'Alignment' projected on the next line. +{-# INLINABLE drawAlignedTxt #-} +drawAlignedTxt :: (Draw e, MonadReader e m, MonadIO m) + => Text + -> LayeredColor + -> Alignment + -> m Alignment +drawAlignedTxt txt colors a = do + d <- asks drawAlignedTxt' + d txt colors a + + +{-# INLINABLE drawTxt #-} +drawTxt :: (Draw e, MonadReader e m, MonadIO m) + => Text + -> Coords Pos + -> LayeredColor + -> m () +drawTxt txt co la = do + d <- asks drawTxt' + d txt co la + + +{-# INLINABLE drawStr #-} +drawStr :: (Draw e, MonadReader e m, MonadIO m) + => String + -> Coords Pos + -> LayeredColor + -> m () +drawStr str co la = do + d <- asks drawStr' + d str co la + +-- | Draws a 'Char' multiple times, starting at the given coordinates and then +-- moving to the right. +{-# INLINABLE drawChars #-} +drawChars :: (Draw e, MonadReader e m, MonadIO m) + => Int + -> Char + -> Coords Pos + -> LayeredColor + -> m () +drawChars i c co la = do + d <- asks drawChars' + d i c co la + +{-# INLINABLE drawChar #-} +drawChar :: (Draw e, MonadReader e m, MonadIO m) + => Char + -> Coords Pos + -> LayeredColor + -> m () +drawChar c co la = do + d <- asks drawChar' + d c co la + +-- | Render the drawing to {the screen, the console, etc...}. +{-# INLINABLE renderToScreen #-} +renderToScreen :: (Render e, MonadReader e m, MonadIO m) + => m () +renderToScreen = + join (asks renderToScreen') diff --git a/src/Imj/Graphics/Render/Naive.hs b/src/Imj/Graphics/Render/Naive.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Graphics/Render/Naive.hs @@ -0,0 +1,59 @@ + +module Imj.Graphics.Render.Naive + ( NaiveDraw(..) + ) where + +import Data.Text(unpack) + +import Control.Monad.Reader(liftIO) + +import System.IO(hFlush, stdout) +import System.Console.ANSI(setCursorPosition, clearFromCursorToScreenEnd) +import System.Console.ANSI.Codes(csi) + +import Imj.Geo.Discrete +import Imj.Graphics.Class.Draw +import Imj.Graphics.Class.Render +import Imj.Graphics.Color.Types + +{- | FOR TESTS ONLY. For production, please use "Imj.Graphics.Render.Delta". + +Naive rendering for the terminal : at every call it sends @color@ and +@position@ change commands, hence + happens very quickly as +a consequence of stdout buffer being automatically flushed to avoid overflow. + +To fix this problem, "Imj.Graphics.Render.Delta" uses double buffering techniques +to limit the actual number of rendering commands sent to stdout. +-} +data NaiveDraw = NaiveDraw + +move' :: Coords Pos -> IO () +move' (Coords (Coord y) (Coord x)) = + setCursorPosition y x + +color :: LayeredColor -> IO () +color (LayeredColor bg fg) = do + let bgCodes = color8BgSGRToCode bg + fgCodes = color8FgSGRToCode fg + putStr $ csi (bgCodes ++ fgCodes) "m" + +-- | Direct draw to stdout : don't use for production, this is for tests only +-- and creates heavy screen tearing. +instance Draw NaiveDraw where + drawChar' _ b c d = liftIO $ move' c >> color d >> putChar b + drawChars' _ b c d e = liftIO $ move' d >> color e >> putStr (replicate b c) + drawTxt' _ b c d = liftIO $ move' c >> color d >> putStr (unpack b) + drawStr' _ b c d = liftIO $ move' c >> color d >> putStr b + {-# INLINABLE drawChar' #-} + {-# INLINABLE drawChars' #-} + {-# INLINABLE drawTxt' #-} + {-# INLINABLE drawStr' #-} + +-- | Direct draw to stdout : don't use for production, this is for tests only +-- and creates heavy screen tearing. +instance Render NaiveDraw where + renderToScreen' _ = liftIO $ hFlush stdout + >> setCursorPosition 0 0 + >> clearFromCursorToScreenEnd + {-# INLINABLE renderToScreen' #-} diff --git a/src/Imj/Graphics/Text/Alignment.hs b/src/Imj/Graphics/Text/Alignment.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Graphics/Text/Alignment.hs @@ -0,0 +1,116 @@ +-- | This module exports functions and types to handle text alignemnt. + +module Imj.Graphics.Text.Alignment + ( -- * Alignment + AlignmentKind(..) + , Alignment(..) + , mkRightAlign + , mkCentered + -- * Helpers + , toNextLine + -- * Utilities + , align + , align' + ) where + +import Imj.Geo.Discrete + +-- | Specifies where the 'Text' is w.r.t the reference coordinates. +data AlignmentKind = Centered + {- ^ /Centered/ on reference coordinates, favoring the 'RIGHT' + side in case of ambiguity: + +@ + 1 + 12 + 123 + 1234 + ^ +@ -} + | RightAligned + {- ^ /Left/ of the reference coordinates, including it: + +@ + 1 + 12 + 123 +1234 + ^ +@ -} + | LeftAligned + {- ^ /Right/ of the reference coordinates, including it: + +@ +1 +12 +123 +1234 +^ +@ +-} + +data Alignment = Alignment { + _alignmentKing :: !AlignmentKind + -- ^ The kind of alignment. + , _alignmentRef :: !(Coords Pos) + -- ^ The reference coordinates. +} + +mkRightAlign :: Coords Pos + -- ^ The text will be written left of these coordinates. + -> Alignment +mkRightAlign = Alignment RightAligned + +mkCentered :: Coords Pos + -- ^ The text will be centered on these coordinates. + -> Alignment +mkCentered = Alignment Centered + +-- | Computes starting coordinates where from we should draw a series of characters +-- of a given length, to meet the alignment constraint. +align' :: Alignment + -> Int + -- ^ number of characters to draw + -> Coords Pos +align' (Alignment a ref) count = + let (amount, dir) = align a count + in move amount dir ref + +{- | Given a number of characters and an alignment, returns the displacement +that should be done relatively to the reference coordinates in order to find +the first character 'Coords'. + +For 'Centered', when we have an /even/ count of characters to draw, we +(somewhat arbitrarily) chose to favor the 'RIGHT' 'Direction', as illustrated +here where @^@ indicates where the reference 'Coords' is: + +@ + 1 + 12 + 123 + 1234 + ^ +@ + +Note that this choice impacts the implementation of +'Imj.Graphics.UI.RectContainer.getSideCentersAtDistance'. +-} +align :: AlignmentKind + -> Int + -- ^ Count of characters + -> (Int, Direction) +align a count = + (amount, LEFT) + where + amount = + case a of + -- for one character, centerered, there is no displacement: + Centered -> quot (count-1) 2 + -- for one character, right aligned, there is no displacement: + RightAligned -> (count - 1) + LeftAligned -> 0 + +-- | Moves the reference coordinate one line down. +toNextLine :: Alignment -> Alignment +toNextLine (Alignment a pos) = + Alignment a $ translateInDir Down pos diff --git a/src/Imj/Graphics/Text/Animation.hs b/src/Imj/Graphics/Text/Animation.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Graphics/Text/Animation.hs @@ -0,0 +1,208 @@ +{-# OPTIONS_HADDOCK prune #-} +{-# LANGUAGE NoImplicitPrelude #-} + +{- | += Examples + +Examples are available in "Imj.Example.SequentialTextTranslationsAnchored": + +* Run @imj-base-examples-exe@ to see these examples displayed in the terminal +-} +module Imj.Graphics.Text.Animation + ( + -- * TextAnimation +{- | +Interpolates between various 'ColorString's, and /at the same time/ interpolates +their anchors. + +Anchors interpolation can occur : + +* at the 'ColorString' level using 'AnchorStrings', or +* at the 'Char' level using 'AnchorChars' -} + TextAnimation(..) + , AnchorChars + , AnchorStrings + -- * Constructors + , mkTextTranslation + , mkSequentialTextTranslationsCharAnchored + , mkSequentialTextTranslationsStringAnchored + -- * Draw + , renderAnimatedTextCharAnchored + , renderAnimatedTextStringAnchored + , getAnimatedTextRenderStates + -- * Reexports + , module Imj.Graphics.Interpolation + ) where + +import Imj.Prelude +import qualified Prelude(length) + +import Control.Monad( zipWithM_ ) +import Control.Monad.IO.Class(MonadIO) +import Control.Monad.Reader.Class(MonadReader) + +import Data.Text( unpack, length ) +import Data.List(foldl', splitAt, unzip) + +import Imj.Geo.Discrete +import Imj.Graphics.Math.Ease +import Imj.Graphics.Interpolation +import Imj.Graphics.Render +import Imj.Graphics.Text.ColorString + + +-- | One anchor per String +data AnchorStrings +-- | One anchor per Character +data AnchorChars + + +-- TODO find a generic implementation: 2 aspects (location and content) are +-- interpolated at the same time. +-- | Interpolates 'ColorString's and anchors. +data TextAnimation a = TextAnimation { + _textAnimationFromTos :: ![Evolution ColorString] -- TODO is it equivalent to Evolution [ColorString]? + , _textAnimationAnchorsFrom :: !(Evolution (SequentiallyInterpolatedList (Coords Pos))) + , _textAnimationClock :: !EaseClock +} deriving(Show) + + +-- | Render a string-anchored 'TextAnimation' for a given 'Frame' +{-# INLINABLE renderAnimatedTextStringAnchored #-} +renderAnimatedTextStringAnchored :: (Draw e, MonadReader e m, MonadIO m) + => TextAnimation AnchorStrings + -> Frame + -> m () +renderAnimatedTextStringAnchored (TextAnimation fromToStrs renderStatesEvolution _) i = do + let rss = getAnimatedTextRenderStates renderStatesEvolution i + renderAnimatedTextStringAnchored' fromToStrs rss i + + +{-# INLINABLE renderAnimatedTextStringAnchored' #-} +renderAnimatedTextStringAnchored' :: (Draw e, MonadReader e m, MonadIO m) + => [Evolution ColorString] + -> [Coords Pos] + -> Frame + -> m () +renderAnimatedTextStringAnchored' [] _ _ = return () +renderAnimatedTextStringAnchored' l@(_:_) rs i = do + let e = head l + rsNow = head rs + colorStr = getValueAt e i + drawColorStr colorStr rsNow + renderAnimatedTextStringAnchored' (tail l) (tail rs) i + +-- | Render a char-anchored 'TextAnimation' for a given 'Frame' +{-# INLINABLE renderAnimatedTextCharAnchored #-} +renderAnimatedTextCharAnchored :: (Draw e, MonadReader e m, MonadIO m) + => TextAnimation AnchorChars + -> Frame + -> m () +renderAnimatedTextCharAnchored (TextAnimation fromToStrs renderStatesEvolution _) i = do + let rss = getAnimatedTextRenderStates renderStatesEvolution i + renderAnimatedTextCharAnchored' fromToStrs rss i + + +{-# INLINABLE renderAnimatedTextCharAnchored' #-} +renderAnimatedTextCharAnchored' :: (Draw e, MonadReader e m, MonadIO m) + => [Evolution ColorString] + -> [Coords Pos] + -> Frame + -> m () +renderAnimatedTextCharAnchored' [] _ _ = return () +renderAnimatedTextCharAnchored' l@(_:_) rs i = do + -- use length of from to know how many renderstates we should take + let e@(Evolution (Successive colorStrings) _ _ _) = head l + nRS = maximum $ map countChars colorStrings + (nowRS, laterRS) = splitAt nRS rs + (ColorString colorStr) = getValueAt e i + renderColorStringAt colorStr nowRS + renderAnimatedTextCharAnchored' (tail l) laterRS i + + +{-# INLINABLE renderColorStringAt #-} +renderColorStringAt :: (Draw e, MonadReader e m, MonadIO m) + => [(Text, LayeredColor)] + -> [Coords Pos] + -> m () +renderColorStringAt [] _ = return () +renderColorStringAt l@(_:_) rs = do + let (txt, color) = head l + len = length txt + (headRs, tailRs) = splitAt len $ assert (Prelude.length rs >= len) rs + zipWithM_ (\char coord -> drawChar char coord color) (unpack txt) headRs + renderColorStringAt (tail l) tailRs + +getAnimatedTextRenderStates :: Evolution (SequentiallyInterpolatedList (Coords Pos)) + -> Frame + -> [Coords Pos] +getAnimatedTextRenderStates evolution i = + let (SequentiallyInterpolatedList l) = getValueAt evolution i + in l + +build :: Coords Pos -> Int -> [Coords Pos] +build x sz = map (\i -> move i RIGHT x) [0..pred sz] + +{- | Translates text in an animated way,ete character by character. + +Examples are given in "Imj.Example.SequentialTextTranslationsAnchored". + -} +mkSequentialTextTranslationsCharAnchored :: [([ColorString], Coords Pos, Coords Pos)] + -- ^ List of (texts, from anchor, to anchor) + -> Float + -- ^ duration in seconds + -> TextAnimation AnchorChars +mkSequentialTextTranslationsCharAnchored l duration = + let (from_,to_) = + foldl' + (\(froms, tos) (colorStrs, from, to) -> + let sz = maximum $ map countChars colorStrs + in (froms ++ build from sz, tos ++ build to sz)) + ([], []) + l + strsEv = map (\(txts,_,_) -> mkEvolutionEaseQuart (Successive txts) duration) l + fromTosLF = maximum $ map (\(Evolution _ lf _ _) -> lf) strsEv + evAnchors@(Evolution _ anchorsLF _ _) = + mkEvolutionEaseQuart (Successive [SequentiallyInterpolatedList from_, + SequentiallyInterpolatedList to_]) duration + in TextAnimation strsEv evAnchors $ mkEaseClock duration (max anchorsLF fromTosLF) invQuartEaseInOut + +{- | Translates text in an animated way, 'ColorString' by 'ColorString'. + +Examples are given in "Imj.Example.SequentialTextTranslationsAnchored". + -} +mkSequentialTextTranslationsStringAnchored :: [([ColorString], Coords Pos, Coords Pos)] + -- ^ List of (texts, from anchor, to anchor) + -> Float + -- ^ Duration in seconds + -> TextAnimation AnchorStrings +mkSequentialTextTranslationsStringAnchored l duration = + let (from_,to_) = unzip $ map (\(_,f,t) -> (f,t)) l + strsEv = map (\(txts,_,_) -> mkEvolutionEaseQuart (Successive txts) duration) l + fromTosLF = maximum $ map (\(Evolution _ lf _ _) -> lf) strsEv + evAnchors@(Evolution _ anchorsLF _ _) = + mkEvolutionEaseQuart (Successive [SequentiallyInterpolatedList from_, + SequentiallyInterpolatedList to_]) duration + in TextAnimation strsEv evAnchors $ mkEaseClock duration (max anchorsLF fromTosLF) invQuartEaseInOut + + +-- | Translates a 'ColorString' between two anchors. +mkTextTranslation :: ColorString + -> Float + -- ^ Duration in seconds + -> Coords Pos + -- ^ Left anchor at the beginning + -> Coords Pos + -- ^ Left anchor at the end + -> TextAnimation AnchorChars +mkTextTranslation text duration from to = + let sz = countChars text + strEv@(Evolution _ fromToLF _ _) = mkEvolutionEaseQuart (Successive [text]) duration + from_ = build from sz + to_ = build to sz + strsEv = [strEv] + fromTosLF = fromToLF + evAnchors@(Evolution _ anchorsLF _ _) = + mkEvolutionEaseQuart (Successive [SequentiallyInterpolatedList from_, + SequentiallyInterpolatedList to_]) duration + in TextAnimation strsEv evAnchors $ mkEaseClock duration (max anchorsLF fromTosLF) invQuartEaseInOut diff --git a/src/Imj/Graphics/Text/ColorString.hs b/src/Imj/Graphics/Text/ColorString.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Graphics/Text/ColorString.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + + {- | A 'ColorString' is a multicolored 'Text'.-} + +module Imj.Graphics.Text.ColorString + ( + -- * Type + ColorString(..) + -- * Constructors + {- | 'colored' creates a 'ColorString' using the specified foreground color on + /black/ background, wherease 'colored'' allows you to chose both the + background and the foreground colors. + +And since 'ColorString' is 'Monoid', we can write: + +@ +str = colored \"Hello\" white <> colored \" World\" yellow +@ + -} + , colored + , colored' + -- * Utilities + , countChars + -- * Reexports + , LayeredColor(..) + ) where + +import Imj.Prelude + +import Data.String(IsString(..)) +import Data.Text( Text, pack, unpack, length ) +import qualified Data.List as List(length) + +import Imj.Graphics.Class.DiscreteInterpolation +import Imj.Graphics.Color.Types +import Imj.Graphics.Text.ColorString.Interpolation +import Imj.Util + +newtype ColorString = ColorString [(Text, LayeredColor)] deriving(Show) + +instance IsString ColorString where + fromString str = ColorString [(pack str, onBlack white)] + + +-- TODO maybe it would be faster to have a representation with Array (Char, LayeredColor) +-- (ie the result of simplify) +-- | First interpolating characters, then color. +instance DiscreteDistance ColorString where + distance c1 c2 = + let colorDist (_, color) (_, color') = distance color color' + n1 = countChars c1 + n2 = countChars c2 + s1 = simplify c1 + s2 = simplify c2 + + (c1', remaining) = interpolateChars s1 s2 countTextChanges + s1' = assert (remaining == 0) c1' + l = zipWith colorDist s1' s2 -- since color interpolation happends AFTER char changes, + -- we compare colors with result of char interpolation + colorDistance = + if null l + then + 1 + else + maximum l + + toString = map fst + str1 = toString s1 + str2 = toString s2 + lPref = List.length $ commonPrefix str1 str2 + lSuff = List.length $ commonSuffix (drop lPref str1) (drop lPref str2) + countTextChanges = max n1 n2 - (lPref + lSuff) + in colorDistance + countTextChanges + +-- | First interpolating characters, then color. +instance DiscreteInterpolation ColorString where + interpolate c1 c2 i = + let c2' = simplify c2 + (c1', remaining) = interpolateChars (simplify c1) c2' i + in ColorString $ map (\(char,color) -> (pack [char], color)) $ + if remaining >= 0 + then + c1' + else + interpolateColors c1' c2' (negate remaining) + + +interpolateColors :: [(Char, LayeredColor)] + -- ^ from + ->[(Char, LayeredColor)] + -- ^ to + -> Int + -- ^ progress + -> [(Char, LayeredColor)] +interpolateColors c1 c2 i = + let z (_, color) (char, color') = (char, interpolate color color' i) + in zipWith z c1 c2 + + +-- | Maps a 'ColorString' to a list of 'Char' and 'LayeredColor'. +-- It is used to simplify the implementation of some interpolation algorithms +simplify :: ColorString -> [(Char, LayeredColor)] +simplify (ColorString []) = [] +simplify (ColorString l@(_:_)) = + let (txt, color) = head l + in map + (\c -> (c,color)) + (unpack txt) + ++ simplify (ColorString $ tail l) + + +colored' :: Text -> LayeredColor -> ColorString +colored' t c = ColorString [(t, c)] + +colored :: Text -> Color8 Foreground -> ColorString +colored t c = colored' t $ onBlack c + +-- | Counts the chars in the 'ColorString' +countChars :: ColorString -> Int +countChars (ColorString cs) = sum $ map (Data.Text.length . fst) cs + +instance Monoid ColorString where + mempty = ColorString [("", onBlack white)] + mappend (ColorString x) (ColorString y) = ColorString $ x ++ y diff --git a/src/Imj/Graphics/Text/ColorString/Interpolation.hs b/src/Imj/Graphics/Text/ColorString/Interpolation.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Graphics/Text/ColorString/Interpolation.hs @@ -0,0 +1,113 @@ +{-# OPTIONS_HADDOCK hide #-} + +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +module Imj.Graphics.Text.ColorString.Interpolation + ( -- * Interpolation + interpolateChars + -- * Helpers + , insertionColor + ) where + +import Imj.Prelude + +import Data.List(length, splitAt) + +import Imj.Graphics.Class.DiscreteInterpolation +import Imj.Graphics.Color.Types +import Imj.Util + + +interpolateChars :: [(Char, LayeredColor)] + -- ^ from + ->[(Char, LayeredColor)] + -- ^ to + -> Int + -- ^ progress + -> ([(Char, LayeredColor)], Int) + -- ^ (result,nSteps) + -- | >=0 : "remaining until completion" + -- | <0 : "completed since" (using abolute value)) +interpolateChars s1 s2 i = + let n1 = length s1 + n2 = length s2 + + toString = map fst + str1 = toString s1 + str2 = toString s2 + lPref = length $ commonPrefix str1 str2 + lSuff = length $ commonSuffix (drop lPref str1) (drop lPref str2) + + -- common prefix, common suffix + + (commonPref, s1AfterCommonPref) = splitAt lPref s1 + commonSuff = drop (n1 - (lSuff + lPref)) s1AfterCommonPref + + -- common differences (ie char changes) + + totalCD = min n1 n2 - (lPref + lSuff) + nCDReplaced = clamp i 0 totalCD + + s2AfterCommonPref = drop lPref s2 + cdReplaced = + -- start with the color of the old char to have a smooth color transition: + zipWith + (\(_, color1) (char2, _) -> (char2, color1)) + (take nCDReplaced s1AfterCommonPref) + (take nCDReplaced s2AfterCommonPref) + + nCDUnchanged = totalCD - nCDReplaced + cdUnchanged = take nCDUnchanged $ drop nCDReplaced s1AfterCommonPref + + -- exclusive differences (ie char deletion or insertion) + -- TODO if n1 > n2, reduce before replacing + signedTotalExDiff = n2 - n1 + signedNExDiff = signum signedTotalExDiff * clamp (i - totalCD) 0 (abs signedTotalExDiff) + (nExDiff1,nExDiff2) = + if signedTotalExDiff >= 0 + then + (0, signedNExDiff) + else + (abs $ signedTotalExDiff - signedNExDiff, 0) + -- TODO use an already existing color instead of switching to the new color immediately + ed1 = take nExDiff1 $ drop totalCD s1AfterCommonPref + ed2 = zipWith + (\idx (char, color) -> (char, fromMaybe color $ insertionColor insertionBounds idx nExDiff2)) + [0..] + $ take nExDiff2 $ drop totalCD s2AfterCommonPref + + insertionBounds :: [LayeredColor] + insertionBounds = catMaybes + [ if null pre + then + Nothing + else + Just $ snd $ last pre + , if null commonSuff + then + Nothing + else + Just $ snd $ head commonSuff ] + + remaining = (totalCD + abs signedTotalExDiff) - i + + pre = commonPref ++ cdReplaced ++ cdUnchanged + in ( pre ++ ed1 ++ ed2 ++ commonSuff + , assert (remaining == max n1 n2 - (lPref + lSuff) - i) remaining) + +-- | Computes color to be applied when a character is inserted +-- in a 'ColorString' (during inteprolation) so that color matches right and or left +-- colors. +insertionColor :: [LayeredColor] -> Int -> Int -> Maybe LayeredColor +insertionColor insertionBounds n total = + case insertionBounds of + [] -> Nothing + [color] -> Just color + [colorFrom, colorTo] -> + let dist = distance colorFrom colorTo + -- when n == -1 we are at colorFrom (frame = 0) + -- when n == total we are at colorTo (frame = pred dist) + frame = round (fromIntegral ((n+1) * pred dist) / fromIntegral (total+1) :: Float) + in Just $ interpolate colorFrom colorTo frame + _ -> error "insertionBounds has at more than 2 elements" diff --git a/src/Imj/Graphics/UI/Animation.hs b/src/Imj/Graphics/UI/Animation.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Graphics/UI/Animation.hs @@ -0,0 +1,179 @@ +{-# OPTIONS_HADDOCK hide #-} -- TODO refactor and doc + +{-# LANGUAGE NoImplicitPrelude #-} + +module Imj.Graphics.UI.Animation + (-- * Animated UI + UIEvolutions(..) + , mkUIAnimation + , UIAnimation(..) + , getDeltaTime + , getUIAnimationDeadline + , renderUIAnimation + , isFinished + , mkTextAnimRightAligned + ) where + +import Imj.Prelude + +import Control.Monad.IO.Class(MonadIO) +import Control.Monad.Reader.Class(MonadReader) + +import Imj.Geo.Discrete +import Imj.Graphics.Render +import Imj.Graphics.Text.Alignment +import Imj.Graphics.Text.Animation +import Imj.Graphics.Text.ColorString +import Imj.Graphics.UI.Colored +import Imj.Graphics.UI.RectContainer +import Imj.Timing + + +-- | Manages the progress and deadline of 'UIEvolutions'. +data UIAnimation = UIAnimation { + _uiAnimationEvs :: !UIEvolutions + , _uiAnimationDeadline :: !(Maybe KeyTime) + -- ^ Time at which the 'UIEvolutions' should be rendered and updated + , _uiAnimationProgress :: !Iteration + -- ^ Current 'Iteration'. +} deriving(Show) + + +-- TODO generalize as an Evolution (text-decorated RectContainer) +-- | Used when transitionning between two levels to smoothly transform the aspect +-- of the 'RectContainer', as well as textual information around it. +data UIEvolutions = UIEvolutions { + _uiEvolutionContainer :: !(Evolution (Colored RectContainer)) + -- ^ The transformation of the 'RectContainer'. + , _uiEvolutionsUpDown :: !(TextAnimation AnchorChars) + -- ^ The transformation of colored text at the top and at the bottom of the 'RectContainer'. + , _uiEvolutionLeft :: !(TextAnimation AnchorStrings) + -- ^ The transformation of colored text left and right of the 'RectContainer'. +} deriving(Show) + + +getUIAnimationDeadline :: UIAnimation -> Maybe KeyTime +getUIAnimationDeadline (UIAnimation _ mayDeadline _) = + mayDeadline + +-- | Is the 'UIAnimation' finished? +isFinished :: UIAnimation -> Bool +isFinished (UIAnimation _ Nothing _) = True +isFinished _ = False + +{-# INLINABLE renderUIAnimation #-} +renderUIAnimation :: (Draw e, MonadReader e m, MonadIO m) + => UIAnimation + -> m () +renderUIAnimation (UIAnimation we@(UIEvolutions frameE upDown left) _ (Iteration _ frame)) = do + let (relFrameFrameE, relFrameUD, relFrameLeft) = getRelativeFrames we frame + drawMorphingAt frameE relFrameFrameE + renderAnimatedTextCharAnchored upDown relFrameUD + renderAnimatedTextStringAnchored left relFrameLeft + +-- | Compute the time interval between the current frame and the next. +getDeltaTime :: UIEvolutions -> Frame -> Maybe Float +getDeltaTime we@(UIEvolutions frameE (TextAnimation _ _ (EaseClock upDown)) (TextAnimation _ _ (EaseClock left))) frame = + let (relFrameFrameE, relFrameUD, relFrameLeft) = getRelativeFrames we frame + in getDeltaTimeToNextFrame frameE relFrameFrameE + <|> getDeltaTimeToNextFrame upDown relFrameUD -- todo in TextAnimation we should have a fake evolution just for timing + <|> getDeltaTimeToNextFrame left relFrameLeft + +getRelativeFrames :: UIEvolutions + -> Frame + -> (Frame, Frame, Frame) +getRelativeFrames + (UIEvolutions (Evolution _ lastFrameE _ _) + (TextAnimation _ _ (EaseClock (Evolution _ lastFrameUD _ _))) _) frame = + let relFrameRectFrameEvol = max 0 frame + relFrameUD = max 0 (relFrameRectFrameEvol - lastFrameE) + relFrameLeft = max 0 (relFrameUD - lastFrameUD) + in (relFrameRectFrameEvol, relFrameUD, relFrameLeft) + + +mkUIAnimation :: (Colored RectContainer, (([ColorString], [ColorString]), [[ColorString]])) + -- ^ From + -> (Colored RectContainer, (([ColorString], [ColorString]), [[ColorString]])) + -- ^ To + -> SystemTime + -- ^ Time at which the animation starts + -> UIAnimation +mkUIAnimation (from@(Colored _ fromR), ((f1,f2),f3)) + (to@(Colored _ toR), ((t1,t2),t3)) t = + UIAnimation evolutions deadline (Iteration (Speed 1) zeroFrame) + where + frameE = mkEvolutionEaseQuart (Successive [from, to]) 1 + + (ta1,ta2) = createUITextAnimations fromR toR (f1++t1, f2++t2, zipWith (++) f3 t3) 1 + evolutions = UIEvolutions frameE ta1 ta2 + deadline = + maybe + Nothing + (\dt -> Just $ KeyTime $ addToSystemTime (floatSecondsToDiffTime dt) t) + $ getDeltaTime evolutions zeroFrame + + +createUITextAnimations :: RectContainer + -- ^ From + -> RectContainer + -- ^ To + -> ([ColorString],[ColorString],[[ColorString]]) + -- ^ Upper text, Lower text, Left texts + -> Float + -> (TextAnimation AnchorChars, TextAnimation AnchorStrings) +createUITextAnimations from to (ups, downs, lefts) duration = + let (centerUpFrom, centerDownFrom, leftMiddleFrom, _) = getSideCentersAtDistance from 3 2 + (centerUpTo, centerDownTo, leftMiddleTo, _) = getSideCentersAtDistance to 3 2 + ta1 = mkTextAnimCenteredUpDown (centerUpFrom, centerDownFrom) (centerUpTo, centerDownTo) (ups, downs) duration + ta2 = mkTextAnimRightAligned leftMiddleFrom leftMiddleTo lefts duration + in (ta1, ta2) + +-- | Creates the 'TextAnimation' to animate the texts that appears left of the main +-- 'RectContainer' + +mkTextAnimRightAligned :: Coords Pos + -- ^ Alignment ref /from/ + -> Coords Pos + -- ^ Alignment ref /to/ + -> [[ColorString]] + -- ^ Each inner list is expected to be of length 1 or more. + -- + -- If length = 1, the 'ColorString' is not animated. Else, the inner list + -- contains 'ColorString' waypoints. + -> Float + -- ^ The duration of the animation + -> TextAnimation AnchorStrings +mkTextAnimRightAligned refFrom refTo listTxts duration = + let l = zipWith (\i txts -> + let firstTxt = head txts + lastTxt = last txts + rightAlign pos = move (2*i) Down . alignTxt (mkRightAlign pos) + fromAligned = rightAlign refFrom firstTxt + toAligned = rightAlign refTo lastTxt + in (txts, fromAligned, toAligned)) + [0..] listTxts + in mkSequentialTextTranslationsStringAnchored l duration + +mkTextAnimCenteredUpDown :: (Coords Pos, Coords Pos) + -> (Coords Pos, Coords Pos) + -> ([ColorString], [ColorString]) + -- ^ Each list is expected to be of size at least 1. + -> Float + -> TextAnimation AnchorChars +mkTextAnimCenteredUpDown (centerUpFrom, centerDownFrom) (centerUpTo, centerDownTo) (txtUppers, txtLowers) + duration = + let alignTxtCentered pos = alignTxt $ mkCentered pos + + centerUpFromAligned = alignTxtCentered centerUpFrom (head txtUppers) + centerUpToAligned = alignTxtCentered centerUpTo (last txtUppers) + + centerDownFromAligned = alignTxtCentered centerDownFrom (head txtLowers) + centerDownToAligned = alignTxtCentered centerDownTo (last txtLowers) + in mkSequentialTextTranslationsCharAnchored + [(txtUppers, centerUpFromAligned, centerUpToAligned), + (txtLowers, centerDownFromAligned, centerDownToAligned)] + duration + +alignTxt :: Alignment -> ColorString -> Coords Pos +alignTxt (Alignment al pos) txt = + uncurry move (align al $ countChars txt) pos diff --git a/src/Imj/Graphics/UI/Colored.hs b/src/Imj/Graphics/UI/Colored.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Graphics/UI/Colored.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Imj.Graphics.UI.Colored + ( Colored(..) + -- * Reexports + , module Imj.Graphics.Class.Colorable + ) where + +import Imj.Prelude + +import Imj.Graphics.Class.Colorable +import Imj.Graphics.Class.DiscreteColorableMorphing +import Imj.Graphics.Class.HasLayeredColor +import Imj.Graphics.Color +import Imj.Graphics.Interpolation + + +data Colored a = Colored { + _coloredColor :: !LayeredColor + , _coloredColorable :: !a +} deriving(Show) + +instance HasLayeredColor (Colored a) where + getColor (Colored color _) = color + {-# INLINABLE getColor #-} + +-- | 'Colored' can wrap a 'Colorable', to give it a notion of color. +instance (Colorable a) + => Drawable (Colored a) where + draw (Colored color colorable) = + drawUsingColor colorable color + +-- | Interpolates the color and morphs the 'Colorable' at the same time. +instance (DiscreteColorableMorphing a) => DiscreteDistance (Colored a) where + distance (Colored colorFrom from) (Colored colorTo to) = + max (distance from to) (distance colorFrom colorTo) + {-# INLINABLE distance #-} + +-- | 'Colored' can wrap a 'DiscreteColorableMorphing', to make a 'DiscreteMorphing'. +-- +-- Interpolates the color and morphs the 'Colorable' at the same time. +instance (DiscreteColorableMorphing a) => DiscreteMorphing (Colored a) where + drawMorphing (Colored colorFrom from) (Colored colorTo to) frame = + drawMorphingUsingColor from to frame (interpolate colorFrom colorTo frame) + {-# INLINABLE drawMorphing #-} diff --git a/src/Imj/Graphics/UI/RectContainer.hs b/src/Imj/Graphics/UI/RectContainer.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Graphics/UI/RectContainer.hs @@ -0,0 +1,269 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE LambdaCase #-} + +module Imj.Graphics.UI.RectContainer + ( + -- * RectContainer + {- | 'RectContainer' represents a rectangular UI container. It + contains the 'Size' of its /content/, and an upper left coordinate. + + Being 'Colorable', it can be wrapped in a 'Colored' to gain the notion of color. -} + RectContainer(..) + , getSideCentersAtDistance + -- * Reexports + , Colorable(..) + ) where + +import Imj.Prelude + +import Data.List( mapAccumL, zip ) +import Control.Monad.IO.Class(MonadIO) +import Control.Monad.Reader.Class(MonadReader) + +import Imj.Geo.Discrete +import Imj.Graphics.Class.DiscreteColorableMorphing +import Imj.Graphics.Render +import Imj.Graphics.UI.RectContainer.MorphParallel4 + +{-| + +@ +r----------------------------+ +| u--+ | +| |//| | +| |//| | +| +--l | +| | ++----------------------------+ + +r = Terminal origin, at (0,0) +/ = RectContainer's content, of size (2,2) +u = RectContainer's upper left corner, at (2,1) +l = RectContainer's lower left corner, at (5,4) +@ +-} +data RectContainer = RectContainer { + _rectFrameContentSize :: !Size + -- ^ /Content/ size. + , _rectFrameUpperLeft :: !(Coords Pos) + -- ^ Upper left corner. +} deriving(Eq, Show) + +-- TODO notion "continuous closed path" to factor 'ranges' and 'renderRectFrameInterpolation' logics. + +instance Colorable RectContainer where + drawUsingColor = renderWhole + {-# INLINABLE drawUsingColor #-} + +-- | Smoothly transforms the 4 sides of the rectangle simultaneously, from their middle +-- to their extremities. +instance DiscreteDistance RectContainer where + {-# INLINABLE distance #-} + distance c@(RectContainer s _) + c'@(RectContainer s' _) + | c == c' = 1 + | otherwise = 1 + quot (1 + max (maxLength s) (maxLength s')) 2 + + +instance DiscreteColorableMorphing RectContainer where + {-# INLINABLE drawMorphingUsingColor #-} + drawMorphingUsingColor from to frame color + | frame <= 0 = drawUsingColor from color + | frame >= lastFrame = drawUsingColor to color + | otherwise = renderRectFrameInterpolation from to lastFrame frame color + where + lastFrame = pred $ distance from to + +{-# INLINABLE renderWhole #-} +renderWhole :: (Draw e, MonadReader e m, MonadIO m) + => RectContainer + -> LayeredColor + -> m () +renderWhole (RectContainer sz upperLeft) = + renderPartialRectContainer sz (upperLeft, 0, countRectContainerChars sz - 1) + +{-# INLINABLE renderRectFrameInterpolation #-} +renderRectFrameInterpolation :: (Draw e, MonadReader e m, MonadIO m) + => RectContainer + -> RectContainer + -> Int + -> Int + -> LayeredColor + -> m () +renderRectFrameInterpolation rf1@(RectContainer sz1 upperLeft1) + rf2@(RectContainer sz2 upperLeft2) lastFrame frame color = do + let (Coords _ (Coord dc)) = diffCoords upperLeft1 upperLeft2 + render di1 di2 = do + let fromRanges = ranges (lastFrame-(frame+di1)) sz1 FromBs + toRanges = ranges (lastFrame-(frame+di2)) sz2 FromAs + mapM_ (renderRectFrameRange rf1 color) fromRanges + mapM_ (renderRectFrameRange rf2 color) toRanges + if dc >= 0 + then + -- expanding animation + render dc 0 + else + -- shrinking animation + render 0 (negate dc) + + +{-# INLINABLE renderRectFrameRange #-} +renderRectFrameRange :: (Draw e, MonadReader e m, MonadIO m) + => RectContainer + -> LayeredColor + -> (Int, Int) + -> m () +renderRectFrameRange (RectContainer sz r) color (min_, max_) = + renderPartialRectContainer sz (r, min_, max_) color + +-- | Considering a closed continuous path with an even number of points labeled +-- A and B and alternating along the path : A,B,A,B,A,B +-- +-- (Think of a rectangle, the middles of the sides being +-- the A points, the extremities being the B points) +-- +-- +-- FromBs is the complement, i.e the same as above, but replacing As with Bs and vice-versa. +data BuildFrom = FromAs + -- ^ First draw A points, then expand the drawn regions + -- to the right and left of A points, until B points are reached. + | FromBs + -- ^ First draw B points, then expand the drawn regions + -- to the right and left of B points, until A points are reached. + +ranges :: Int + -- ^ Progress of the interpolation + -> Size + -- ^ Size of the content, /not/ the container + -> BuildFrom + -- ^ The building strategy + -> [(Int, Int)] +ranges progress sz = + let h = countRectContainerVerticalChars sz + w = countRectContainerHorizontalChars sz + + diff = quot (w - h) 2 -- vertical and horizontal animations should start at the same time + + extW = rangeByRemovingFromTotal progress w + extH = rangeByRemovingFromTotal (max 0 $ progress-diff) h + + exts = [extW, extH, extW, extH] + lengths = [w,h,w,h] + + (total, starts) = mapAccumL (\acc v -> (acc + v, acc)) 0 lengths + res = map (\(ext, s) -> ext s) $ zip exts starts + in \case + FromAs -> res + FromBs -> complement 0 (total-1) res + +complement :: Int -> Int -> [(Int, Int)] -> [(Int, Int)] +complement a max_ [] = [(a, max_)] +complement a max_ l@((b,c):_) = (a, pred b) : complement (succ c) max_ (tail l) + +rangeByRemovingFromTotal :: Int -> Int -> Int -> (Int, Int) +rangeByRemovingFromTotal remove total start = + let min_ = remove + max_ = total - 1 - remove + in (start + min_, start + max_) + + +-- TODO split : function to make the container at a distance, and function to take the centers. +{- | Returns points centered on the sides of a container which is at a given distances +(dx and dy) from the reference container. + +[container at a distance from another container] +In this illustration, @cont'@ is at dx = dy = 3 from @cont@: + +@ + cont' + +--------+..- + | | | dy = 3 + | cont | | + | +--+..|..- + | | | | + | | | | + | +--+ | + | . | + | . | + +--------+ + . . + . . + >|--|< + dx = 3 +@ + +[Favored direction for centers of horizontal sides] +When computing the /center/ of an horizontal side, if the side has an /even/ length, +we must favor a 'Direction'. +(Note that if the side has an /odd/ length, there is no ambiguity.) + +In 'Text.Alignment.align' implementation, 'Text.Alignment.Centered' alignment +favors the 'RIGHT' 'Direction': + +@ + 1 + 12 + 123 + 1234 + ^ +@ + + +* If we, too, favor the 'RIGHT' 'Direction', when the returned point is used as +reference for a 'Centered' alignment, the text will tend to be too far to the 'RIGHT', +as illustrated here (@^@ indicates the chosen center): + +@ + 1 + +--+ + 12 + +--+ + 123 + +--+ + 1234 + +--+ + ^ +@ + +* So we will favor the 'LEFT' 'Direction', to counterbalance the choice made in +'Text.Alignment.align' 's implementation: + +@ + 1 + +--+ + 12 + +--+ + 123 + +--+ + 1234 + +--+ + ^ +@ +-} +getSideCentersAtDistance :: RectContainer + -- ^ Reference container + -> Length Width + -- ^ Horizontal distance + -> Length Height + -- ^ Horizontal distance + -> (Coords Pos, Coords Pos, Coords Pos, Coords Pos) + -- ^ (center Up, center Down, center Left, center Right) +getSideCentersAtDistance (RectContainer (Size rs' cs') upperLeft') dx dy = + (centerUp, centerDown, leftMiddle, rightMiddle) + where + deltaLength dist = + 2 * -- in both directions + (1 + -- from inner content to outer container + dist) -- from container to container' + rs = rs' + fromIntegral (deltaLength dy) + cs = cs' + fromIntegral (deltaLength dx) + upperLeft = translate' (fromIntegral $ -dy) (fromIntegral $ -dx) upperLeft' + + cHalf = quot (cs-1) 2 -- favors 'LEFT' 'Direction', see haddock comments. + rHalf = quot (rs-1) 2 -- favors 'Up' 'Direction' + rFull = rs-1 + + centerUp = translate' 0 cHalf upperLeft + centerDown = translate' rFull cHalf upperLeft + leftMiddle = translate' rHalf 0 upperLeft + rightMiddle = translate' rHalf (cs-1) upperLeft diff --git a/src/Imj/Graphics/UI/RectContainer/MorphParallel4.hs b/src/Imj/Graphics/UI/RectContainer/MorphParallel4.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Graphics/UI/RectContainer/MorphParallel4.hs @@ -0,0 +1,130 @@ +{-# OPTIONS_HADDOCK hide #-} + +{-# LANGUAGE NoImplicitPrelude #-} + +module Imj.Graphics.UI.RectContainer.MorphParallel4 + ( renderPartialRectContainer + , countRectContainerHorizontalChars + , countRectContainerVerticalChars + , countRectContainerChars + ) where + +import Imj.Prelude + +import Control.Monad.IO.Class(MonadIO) +import Control.Monad.Reader.Class(MonadReader) + +import Imj.Graphics.Render +import Imj.Geo.Discrete + + +countRectContainerChars :: Size -> Int +countRectContainerChars s = + 2 * countRectContainerHorizontalChars s + 2 * countRectContainerVerticalChars s + +countRectContainerHorizontalChars :: Size -> Int +countRectContainerHorizontalChars (Size _ cs) = + fromIntegral cs + 2 + +countRectContainerVerticalChars :: Size -> Int +countRectContainerVerticalChars (Size rs _) = + fromIntegral rs + +{-# INLINABLE renderPartialRectContainer #-} +renderPartialRectContainer :: (Draw e, MonadReader e m, MonadIO m) + => Size + -- ^ Dimensions of the content of the container + -> (Coords Pos, Int, Int) + -- ^ Coordinates of the upper left corner of the container, from, to. + -> LayeredColor + -> m () +renderPartialRectContainer sz r colors = + renderUpperWall sz colors r + >>= renderRightWall sz colors + >>= renderLowerWall sz colors + >>= renderLeftWall sz colors + >> return () + +{-# INLINABLE renderLeftWall #-} +renderLeftWall :: (Draw e, MonadReader e m, MonadIO m) + => Size + -> LayeredColor + -> (Coords Pos, Int, Int) + -> m (Coords Pos, Int, Int) +renderLeftWall = renderSideWall Up + +{-# INLINABLE renderRightWall #-} +renderRightWall :: (Draw e, MonadReader e m, MonadIO m) + => Size + -> LayeredColor + -> (Coords Pos, Int, Int) + -> m (Coords Pos, Int, Int) +renderRightWall = renderSideWall Down + +{-# INLINABLE renderSideWall #-} +renderSideWall :: (Draw e, MonadReader e m, MonadIO m) + => Direction + -> Size + -> LayeredColor + -> (Coords Pos, Int, Int) + -> m (Coords Pos, Int, Int) +renderSideWall dir sz colors (ref, from, to) = do + let countMax = countRectContainerVerticalChars sz + (actualFrom, actualTo) = actualRange countMax (from, to) + nChars = 1 + actualTo - actualFrom + wallCoords = map (\n -> move n dir ref) [actualFrom..actualTo] + nextRef = move countMax dir ref + mapM_ (\pos -> drawChar '|' pos colors) wallCoords + if nChars <= 0 + then + return (nextRef, from - countMax, to - countMax) + else + return (nextRef, from + nChars - countMax, to - countMax) + +{-# INLINABLE renderUpperWall #-} +renderUpperWall :: (Draw e, MonadReader e m, MonadIO m) + => Size + -> LayeredColor + -> (Coords Pos, Int, Int) + -> m (Coords Pos, Int, Int) +renderUpperWall = + renderHorizontalWall Down RIGHT '_' + +{-# INLINABLE renderLowerWall #-} +renderLowerWall :: (Draw e, MonadReader e m, MonadIO m) + => Size + -> LayeredColor + -> (Coords Pos, Int, Int) + -> m (Coords Pos, Int, Int) +renderLowerWall = + renderHorizontalWall Up LEFT 'T' + +{-# INLINABLE renderHorizontalWall #-} +renderHorizontalWall :: (Draw e, MonadReader e m, MonadIO m) + => Direction + -> Direction + -> Char + -> Size + -> LayeredColor + -> (Coords Pos, Int, Int) + -> m (Coords Pos, Int, Int) +renderHorizontalWall dirV dirH char sz colors (upperLeft, from, to) = do + let countMax = countRectContainerHorizontalChars sz + (actualFrom, actualTo) = actualRange countMax (from, to) + nChars = 1 + actualTo - actualFrom + nextR = translateInDir dirV $ move (countMax - 1) dirH upperLeft + startDraw = case dirH of + RIGHT -> move actualFrom RIGHT upperLeft + LEFT -> move actualTo LEFT upperLeft + _ -> error "not allowed" + if nChars <= 0 + then + return (nextR, from - countMax, to - countMax) + else + drawChars nChars char startDraw colors + >> return (nextR, from + nChars - countMax, to - countMax) + + +actualRange :: Int -> (Int, Int) -> (Int, Int) +actualRange countMax (from, to) = + (max 0 from, min to $ pred countMax) diff --git a/src/Imj/Input.hs b/src/Imj/Input.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Input.hs @@ -0,0 +1,16 @@ + +{- | This module exports functions and types allowing to read player key-presses. + +When we read a key with 'getKeyThenFlush' or 'tryGetKeyThenFlush', +we flush 'stdin' just after having read from it, to avoid repeated keys +slowing down the game. +-} +module Imj.Input + ( module Imj.Input.Types + , module Imj.Input.Blocking + , module Imj.Input.NonBlocking + ) where + +import Imj.Input.Types +import Imj.Input.Blocking +import Imj.Input.NonBlocking diff --git a/src/Imj/Input/Blocking.hs b/src/Imj/Input/Blocking.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Input/Blocking.hs @@ -0,0 +1,62 @@ +{-# OPTIONS_HADDOCK hide #-} + +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE LambdaCase #-} + +module Imj.Input.Blocking + ( -- * Blocking read + getKeyThenFlush + ) where + + +import Imj.Prelude + +import System.IO( getChar, hReady, stdin ) + +import Data.Char( ord ) +import Data.List( reverse ) + +import Imj.Geo.Discrete.Types( Direction(..) ) +import Imj.Input.Types + +-- | Blocks until a key is read from stdin. Then, flushes stdin. +getKeyThenFlush :: IO Key +getKeyThenFlush = do + chars <- getAllChars + let res = fromString chars + -- uncomment to see escape codes + -- when (ord (head chars) == 27) $ putStrLn $ tail chars + return res + +fromString :: String -> Key +fromString = + \case + [] -> error "should not be empty" + [c] -> case ord c of + 27 {-ESC-} -> Escape + _ -> AlphaNum c + c:l -> case ord c of + 27 {-ESC-} -> case l of + a:b:_ -> case a of + '[' -> case b of + 'A' -> Arrow Up + 'B' -> Arrow Down + 'C' -> Arrow RIGHT + 'D' -> Arrow LEFT + _ -> Unknown + _ -> Unknown + _ -> Unknown + _ -> AlphaNum c + +-- | returns when stdin is empty +getAllChars :: IO String +getAllChars = + reverse <$> getKey' "" + where getKey' chars = do + char <- getChar + more <- hReady stdin + (if more + then + getKey' + else + return) (char:chars) diff --git a/src/Imj/Input/NonBlocking.hs b/src/Imj/Input/NonBlocking.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Input/NonBlocking.hs @@ -0,0 +1,29 @@ +{-# OPTIONS_HADDOCK hide #-} + +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE LambdaCase #-} + +module Imj.Input.NonBlocking + ( -- * Non-blocking read + tryGetKeyThenFlush + ) where + +import Imj.Prelude + +import System.IO( hReady + , stdin) + +import Imj.Input.Types +import Imj.Input.Blocking + +callIf :: IO a -> IO Bool -> IO (Maybe a) +callIf call condition = + condition >>= \case + True -> Just <$> call + False -> return Nothing + +-- | Tries to read a key from stdin. If it succeeds, it flushes stdin. +tryGetKeyThenFlush :: IO (Maybe Key) +tryGetKeyThenFlush = getKeyThenFlush `callIf` someInputIsAvailable + where + someInputIsAvailable = hReady stdin diff --git a/src/Imj/Input/Types.hs b/src/Imj/Input/Types.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Input/Types.hs @@ -0,0 +1,20 @@ +{-# OPTIONS_HADDOCK hide #-} + +{-# LANGUAGE NoImplicitPrelude #-} + +module Imj.Input.Types + ( Key(..) + ) where + +import Imj.Prelude +import Imj.Geo.Discrete.Types( Direction(..) ) + +-- | Represents a key-press, read from stdin. +data Key = AlphaNum Char + -- ^ An alphanumeric key + | Arrow Direction + -- ^ One of the four direction arrows + | Escape + -- ^ The escape key + | Unknown + -- ^ An unhandled key diff --git a/src/Imj/Iteration.hs b/src/Imj/Iteration.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Iteration.hs @@ -0,0 +1,43 @@ +{-# OPTIONS_HADDOCK prune #-} + +-- | Functions and types around the notion of iteration. +-- +-- Iterations are used for animations ("Imj.Graphics.Animation.Design") and +-- evolutions ("Imj.Graphics.Interpolation.Evolution"). +{-# LANGUAGE GeneralizedNewtypeDeriving, NoImplicitPrelude #-} + +module Imj.Iteration + ( Iteration(..) + , Speed(..) + , Frame(..) + , zeroFrame + , zeroIteration + , nextIteration + , previousIteration + ) where + +import Imj.Prelude + +-- | An 'Iteration' has a 'Speed' and an iterator: 'Frame' +data Iteration = Iteration !Speed !Frame deriving(Show) + +-- | The 'Speed' at which the iteration occurs (if speed > 1, some 'Frame's are skipped). +newtype Speed = Speed Int deriving(Eq, Show, Num, Integral, Real, Enum, Ord) + +-- | Iterator of 'Iteration' +newtype Frame = Frame Int deriving(Eq, Show, Num, Integral, Real, Enum, Ord) + + +zeroIteration :: Speed -> Iteration +zeroIteration s = Iteration s zeroFrame + +-- | Iterates forward. +nextIteration :: Iteration -> Iteration +nextIteration (Iteration s@(Speed speed) (Frame i)) = Iteration s (Frame (i + speed)) + +-- | Iterates backward. +previousIteration :: Iteration -> Iteration +previousIteration (Iteration s@(Speed speed) (Frame i)) = Iteration s (Frame (i - speed)) + +zeroFrame :: Frame +zeroFrame = Frame 0 diff --git a/src/Imj/Physics/Discrete.hs b/src/Imj/Physics/Discrete.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Physics/Discrete.hs @@ -0,0 +1,7 @@ +module Imj.Physics.Discrete + ( module Imj.Physics.Discrete.Types + , module Imj.Physics.Discrete.Collision + ) where + +import Imj.Physics.Discrete.Types +import Imj.Physics.Discrete.Collision diff --git a/src/Imj/Physics/Discrete/Collision.hs b/src/Imj/Physics/Discrete/Collision.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Physics/Discrete/Collision.hs @@ -0,0 +1,111 @@ +{-# OPTIONS_HADDOCK hide #-} + +{-# LANGUAGE NoImplicitPrelude #-} + +module Imj.Physics.Discrete.Collision + ( -- * Handling collisions + {- | To give a better realism in the game, if the location + /before/ a collision is not touching a wall, then the position /after/ the + collision will be forced to touch a wall. Note that forcing the position + only happens if the absolute speed of one coordinate is >= 2. + -} + mirrorSpeedAndMoveToPrecollisionIfNeeded + , CollisionStatus(..) + , firstCollision + , Location(..) + ) where + +import Imj.Prelude + +import Imj.Geo.Discrete +import Imj.Physics.Discrete.Types + + +-- | Describes if a collision exists. +data Location = InsideWorld + -- ^ No collision. + | OutsideWorld + -- ^ A collision exists. + deriving(Eq, Show) + +data CollisionStatus = NoCollision + -- ^ no collision on the trajectory, position is unchanged + | PreCollision + -- ^ a collision exists on the trajectory, + -- position was changed to be just before the collision + -- and speed was mirrored + +-- | On collision, mirrors speed and moves to the pre-collision position. +mirrorSpeedAndMoveToPrecollisionIfNeeded :: (Coords Pos -> Location) + -- ^ Interaction function. + -> PosSpeed + -- ^ Input position and speed. + -> (PosSpeed, CollisionStatus) + -- ^ The speed was potentially mirrored +mirrorSpeedAndMoveToPrecollisionIfNeeded getLocation posspeed@(PosSpeed pos speed) = + maybe + (posspeed, NoCollision) + adjustPosSpeed + $ firstCollision getLocation trajectory + where + trajectory = bresenham $ mkSegment pos $ sumPosSpeed pos speed + adjustPosSpeed (mirror, newPos) = (PosSpeed newPos $ mirrorSpeed speed mirror, PreCollision) + +-- | Handles the first collision on a trajectory, assuming that the first position +-- has no collision. +firstCollision :: (Coords Pos -> Location) + -- ^ The collision function. + -> [Coords Pos] + -- ^ The trajectory (the first position is expected to be collision-free). + -> Maybe (Mirror, Coords Pos) + -- ^ On collision, the kind of speed mirroring + -- that should be applied and the position just before the collision. +firstCollision getLocation (p1:theRest@(p2:_)) = + mirrorIfNeededAtomic getLocation (PosSpeed p1 (diffPosToSpeed p2 p1)) <|> firstCollision getLocation theRest +firstCollision _ _ = Nothing + +-- | Mirrors a speed +mirrorSpeed :: Coords Vel -> Mirror -> Coords Vel +mirrorSpeed (Coords dr dc) m = + case m of + MirrorRow -> Coords (negate dr) dc + MirrorCol -> Coords dr (negate dc) + MirrorAll -> Coords (negate dr) (negate dc) + +-- | The kind of speed mirroring to apply in reaction to a collision. +data Mirror = MirrorRow + -- ^ Mirror the y coordinate + | MirrorCol + -- ^ Mirror the x coordinate + | MirrorAll + -- ^ Mirror x and y coordinates + +-- | When continuing with current speed, if at next iteration we encounter a wall +-- (or go through a wall for diagonal case), +-- we change the speed according to the normal of the closest wall before collision +mirrorIfNeededAtomic :: (Coords Pos -> Location) -> PosSpeed -> Maybe (Mirror, Coords Pos) +mirrorIfNeededAtomic getLocation (PosSpeed pos@(Coords r c) (Coords dr dc)) = + let future = Coords (r+dr) (c+dc) + isWall coord = getLocation coord == OutsideWorld + mirror = case getLocation future of + OutsideWorld + | dr == 0 -> Just MirrorCol + | dc == 0 -> Just MirrorRow + | otherwise -> -- diagonal case + case (isWall (Coords (r+dr) c), + isWall (Coords r (c+dc))) of + (True, True) -> Just MirrorAll + (False, False) -> Just MirrorAll + (True, False) -> Just MirrorRow + (False, True) -> Just MirrorCol + InsideWorld + | dr == 0 -> Nothing + | dc == 0 -> Nothing + | otherwise -> -- diagonal case + case (isWall (Coords (r+dr) c), + isWall (Coords r (c+dc))) of + (True, True) -> Just MirrorAll + (False, False) -> Nothing + (True, False) -> Just MirrorRow + (False, True) -> Just MirrorCol + in maybe Nothing (\m -> Just (m, pos)) mirror diff --git a/src/Imj/Physics/Discrete/Types.hs b/src/Imj/Physics/Discrete/Types.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Physics/Discrete/Types.hs @@ -0,0 +1,21 @@ +{-# OPTIONS_HADDOCK hide #-} + +{-# LANGUAGE NoImplicitPrelude #-} + +module Imj.Physics.Discrete.Types + ( -- * Discrete position and speed + {- | In a terminal, it is only possible to represent objects at /discrete/ + locations, hence, movable objects have /discrete/ speeds and + positions. -} + PosSpeed(..) + ) where + +import Imj.Prelude + +import Imj.Geo.Discrete.Types + +-- | Represents a discrete position and a discrete speed. +data PosSpeed = PosSpeed { + _posSpeedPos :: !(Coords Pos) + , _posSpeedSpeed :: !(Coords Vel) +} deriving (Eq, Show) diff --git a/src/Imj/Threading.hs b/src/Imj/Threading.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Threading.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Imj.Threading + ( -- * Threads + {- | + We use a separate thread to run the game, to be able to catch Ctrl-C related exception, + and reset console settings before quitting. + + It doesn't seem to always work, maybe we should use + instead. + -} + runAndWaitForTermination + , Termination(..) + , setupCapabilities + ) where + +import Imj.Prelude +import qualified Prelude + +import GHC.Conc(getNumProcessors) +import Control.Concurrent( forkFinally + , MVar + , newEmptyMVar + , putMVar + , readMVar + , setNumCapabilities ) +import Control.Exception( SomeException(..) ) +import Control.Monad( (>=>) ) + +-- | Was the thread termination normal or due to an error? +data Termination = NormalTermination + | AbnormalTermination + +-- | Runs an IO action in a separate thread, and waits for it to finish, +-- returning its result. +runAndWaitForTermination :: IO () -> IO Termination +runAndWaitForTermination io = do + --setupCapabilities + -- launch game thread + gameThreadTerminated <- myForkIO io + -- wait for game thread to finish + readMVar gameThreadTerminated + +-- | Sets the number of capabilities to half the number of processors. +-- Not used at the moment since we don't use parallelism too much. +setupCapabilities :: IO () +setupCapabilities = do + nproc <- getNumProcessors + let ncap = max 1 $ quot nproc 2 + setNumCapabilities ncap + + +-- This function was introduced so that the parent thread can wait on the +-- returned MVar to be set to know that the child thread has terminated. +-- cf https://hackage.haskell.org/package/base-4.10.0.0/docs/Control-Concurrent.html#g:12 +myForkIO :: IO () -> IO (MVar Termination) +myForkIO io = do + mvar <- newEmptyMVar + _ <- forkFinally io (handleTerminationCause >=> putMVar mvar) + return mvar + + +handleTerminationCause :: Either SomeException a -> IO Termination +handleTerminationCause (Left e) = do + Prelude.putStrLn ("From game thread:\n" ++ show e) + return AbnormalTermination +handleTerminationCause _ = return NormalTermination diff --git a/src/Imj/Timing.hs b/src/Imj/Timing.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Timing.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +-- | This modules exports types and functions related to timing. + +module Imj.Timing + ( -- * KeyTime + {- | A wrapper type on 'SystemTime' -} + KeyTime(..) + , addDuration + -- * SystemTime / DiffTime utilities + , addToSystemTime + , diffSystemTime + , diffTimeSecToMicros + , floatSecondsToDiffTime + -- * Reexports + , SystemTime(..) + , DiffTime + , getSystemTime + ) where + +import Imj.Prelude +import Prelude(Integer) + +import Data.Int(Int64) +import Data.Time(DiffTime, diffTimeToPicoseconds, + secondsToDiffTime, picosecondsToDiffTime) +import Data.Time.Clock.System + (getSystemTime, SystemTime(..) ) + +-- | Adds a 'DiffTime' to a 'SystemTime' +addToSystemTime :: DiffTime -> SystemTime -> SystemTime +addToSystemTime diff t = + let d = diffTimeToSystemTime diff + in sumSystemTimes d t + +-- | Returns t1-t2 +diffSystemTime :: SystemTime + -- ^ t1 + -> SystemTime + -- ^ t2 + -> DiffTime +diffSystemTime (MkSystemTime s1 ns1) (MkSystemTime s2 ns2) = + let -- ns1 and ns2 are Word32, which is an unsigned type. + -- To avoid underflowing Word32, to compute their difference, we use + -- the next bigger signed type : Int64. + ns1', ns2' :: Int64 + ns1' = fromIntegral ns1 + ns2' = fromIntegral ns2 + nsDiff = ns1' - ns2' + in secondsToDiffTime (fromIntegral $ s1 - s2) + + picosecondsToDiffTime (fromIntegral nsDiff * 1000) + +sumSystemTimes :: SystemTime -> SystemTime -> SystemTime +sumSystemTimes (MkSystemTime s1 ns1) (MkSystemTime s2 ns2) = + let s = s1 + s2 + ns = ns1 + ns2 -- no overflow, even if both contain leap seconds because 2^32 > 4 * 1000000000 + (addS, nanoseconds) = ns `quotRem` 1000000000 + in MkSystemTime (s + fromIntegral addS) nanoseconds + + +picoToNano :: Integer -> Integer +picoToNano i = quot i 1000 + +diffTimeToSystemTime :: DiffTime -> SystemTime +diffTimeToSystemTime diff = + let nanoDiff :: Integer + nanoDiff = picoToNano $ diffTimeToPicoseconds diff + -- using divMod with a positive divisor, + -- nanoseconds is guaranteed to be positive, seconds may be negative + (seconds, nanoseconds) = nanoDiff `divMod` 1000000000 + in MkSystemTime (fromIntegral seconds) (fromIntegral nanoseconds) + +-- | Represents deadlines and event times. +newtype KeyTime = KeyTime SystemTime deriving(Eq, Ord, Show) + +-- | Convert a 'DiffTime' to a number of microseconds. +diffTimeSecToMicros :: DiffTime -> Int +diffTimeSecToMicros t = floor (t * 10^(6 :: Int)) + +microSecondsPerSecond :: Integer +microSecondsPerSecond = 1000000 + +-- | Converts a duration expressed in seconds using a 'Float' to a 'DiffTime' +-- which has picosecond resolution. +floatSecondsToDiffTime :: Float -> DiffTime +floatSecondsToDiffTime f = microsecondsToDiffTime $ floor (f*fromIntegral microSecondsPerSecond) + +microsecondsToDiffTime :: Integer -> DiffTime +microsecondsToDiffTime x = fromRational (x % fromIntegral microSecondsPerSecond) + +-- | Adds a 'DiffTime' to a 'KeyTime'. +addDuration :: DiffTime -> KeyTime -> KeyTime +addDuration durationSeconds (KeyTime t) = + KeyTime $ addToSystemTime durationSeconds t diff --git a/src/Imj/Util.hs b/src/Imj/Util.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Util.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Imj.Util + ( -- * List utilities + showListOrSingleton + , replicateElements + , range + -- * String utilities + , commonPrefix + , commonSuffix + -- * Math utilities + , randomRsIO + , clamp + -- * Reexports + , Int64 + ) where + +import Imj.Prelude + +import Data.Int(Int64) +import Data.List(reverse) +import Data.Text(Text, pack) + +import Control.Arrow( first ) + +import System.Random( Random(..) + , getStdRandom + , split ) + + +{-# INLINABLE showListOrSingleton #-} +-- | If list is a singleton, show the element, else show the list. +showListOrSingleton :: Show a => [a] -> Text +showListOrSingleton [e] = pack $ show e +showListOrSingleton l = pack $ show l + +{-# INLINE replicateElements #-} +-- | Replicates each list element n times and concatenates the result. +replicateElements :: Int -> [a] -> [a] +replicateElements n = concatMap (replicate n) + +{-# INLINABLE range #-} +{- | Builds a range with no constraint on the order of bounds: + +@ +range 3 5 == [3,4,5] +range 5 3 == [5,4,3] +@ +-} +range :: Enum a => Ord a + => a -- ^ First inclusive bound + -> a -- ^ Second inclusive bound + -> [a] +range n m = + if m < n + then + [n,(pred n)..m] + else + [n..m] + +-- | Returns a list of random values uniformly distributed in the closed interval +-- [lo,hi]. +-- +-- It is unspecified what happens if lo>hi +randomRsIO :: Random a + => a -- ^ lo : lower bound + -> a -- ^ hi : upper bound + -> IO [a] +randomRsIO from to = + getStdRandom $ split >>> first (randomRs (from, to)) + +commonPrefix :: String -> String -> String +commonPrefix (x:xs) (y:ys) + | x == y = x : commonPrefix xs ys +commonPrefix _ _ = [] + +commonSuffix :: String -> String -> String +commonSuffix s s' = reverse $ commonPrefix (reverse s) (reverse s') + + +-- | Expects the bounds to be in the right order. +{-# INLINABLE clamp #-} +clamp :: Ord a + => a + -- ^ The value + -> a + -- ^ The inclusive minimum bound + -> a + -- ^ The inclusive maximum bound + -> a +clamp n min_ max_ + | n < min_ = min_ + | n > max_ = max_ + | otherwise = n diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,26 @@ +import System.Console.ANSI(clearScreen) +import Control.Monad.Reader(runReaderT) + +import Imj.Graphics.Render +import Imj.Graphics.Render.Naive + +--import Test.Imj.Ease +import Test.Imj.Vector +import Test.Imj.Bresenham3 +import Test.Imj.Timing +import Test.Imj.Interpolation +import Test.Imj.InterpolatedColorString + +main :: IO () +main = do + putStrLn "" -- for readablilty + testBres3 >>= print + testTiming >>= print + testVector >>= print + testInterpolation + + clearScreen -- to not overwrite current terminal content. + runReaderT (testICS >> + renderToScreen + ) (NaiveDraw) + --testEase diff --git a/test/Test/Imj/Bresenham3.hs b/test/Test/Imj/Bresenham3.hs new file mode 100644 --- /dev/null +++ b/test/Test/Imj/Bresenham3.hs @@ -0,0 +1,39 @@ +{-# OPTIONS_HADDOCK hide #-} + +{-# LANGUAGE BangPatterns #-} + +module Test.Imj.Bresenham3(testBres3) where + +import Imj.Geo.Discrete.Bresenham3 + +testBres3 :: IO Bool +testBres3 = do + let n = 8 :: Int + pairs = [((x,y,z),(x',y',z')) | x <- [0..n], y <- [0..n], z <- [0..n], + x' <- [0..n], y' <- [0..n], z' <- [0..n]] + l <- mapM test pairs + let s = sum l + return $ length pairs == s -- True on success (on error, an error has already terminated the program) + + +-- | returns 1 on success, else errors +test :: ((Int, Int, Int),(Int, Int, Int)) -> IO Int +test (from, to) = do + --putStrLn $ show from ++ show to + let d = bresenham3Length from to + br = bresenham3 from to + !res -- we use a bang here so that it is concomittent with previous putStrLn + |length br /= d = error "different lengths" + |head br /= from = error "wrong head" + |last br /= to = error $ show from ++ show to ++ "wrong last " ++ show (last br) + |verifyDistances br = error $ show from ++ show to ++ "wrong distances" ++ show br + -- now the bresenham line is valid + |otherwise = 1 + return res + +verifyDistances :: [(Int,Int,Int)] -> Bool +verifyDistances [] = False +verifyDistances [_] = False +verifyDistances l@((x,y,z):(x',y',z'):_) = + let dist = max (abs (x-x')) (max (abs (y-y')) (abs (z-z'))) + in dist > 1 || verifyDistances (tail l) diff --git a/test/Test/Imj/Ease.hs b/test/Test/Imj/Ease.hs new file mode 100644 --- /dev/null +++ b/test/Test/Imj/Ease.hs @@ -0,0 +1,21 @@ + +module Test.Imj.Ease (testEase) where + +import Imj.Graphics.Math.Ease + + +testEase :: IO() +testEase = do + putStrLn "" + test invQuartEaseInOut + putStrLn "" + test quartInOut + +test :: (Float -> Float) -> IO () +test ease = mapM_ (\v -> putStrLn $ show v) $ map ease $ map (\i -> fromIntegral i / 10.0) [(0 :: Int)..10] + +quartInOut :: Float -> Float +quartInOut time = + if time < 0.5 + then 1 / 2 * 2**4 * time * time * time * time + else negate 1 / 2 * (2**4 * (time-1) * (time-1) * (time-1) * (time-1) - 2) diff --git a/test/Test/Imj/InterpolatedColorString.hs b/test/Test/Imj/InterpolatedColorString.hs new file mode 100644 --- /dev/null +++ b/test/Test/Imj/InterpolatedColorString.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Imj.InterpolatedColorString(testICS) where + +import Control.Monad.IO.Class(MonadIO) +import Control.Monad.Reader.Class(MonadReader) +import Control.Monad(void) + +import Data.Monoid((<>)) + +import Imj.Geo.Discrete +import Imj.Graphics.Color +import Imj.Graphics.Interpolation +import Imj.Graphics.Render +import Imj.Graphics.Text.ColorString + +testICS :: (Draw e, MonadReader e m, MonadIO m) + => m () +testICS = do + + let from = colored "hello" (rgb 5 0 0) <> colored " world" (rgb 0 5 0) <> colored " :)" (rgb 3 5 1) + to = colored "hello" (rgb 5 5 5) <> colored " world" (rgb 1 2 5) <> colored " :)" (rgb 5 1 4) + e@(Evolution _ (Frame lastFrame) _ _) = mkEvolutionEaseQuart (Successive [from, to]) 1 + from' = colored "travel" (rgb 5 0 0) + to' = colored "trail" (rgb 5 5 5) + e'@(Evolution _ (Frame lastFrame') _ _) = mkEvolutionEaseQuart (Successive [from', to']) 1 + pFrom = colored "[.]" (rgb 5 5 5) + pTo = colored "[......]" (rgb 5 5 5) + e''@(Evolution _ (Frame lastFrame'') _ _) = mkEvolutionEaseQuart (Successive [pFrom, pTo]) 1 + p1 = colored "[.]" (rgb 5 5 5) + p2 = colored "[.]" (rgb 5 0 0) + e'''@(Evolution _ (Frame lastFrame''') _ _) = mkEvolutionEaseQuart (Successive [p1,p2,p1]) 1 + + mapM_ + (\i@(Frame c') -> do + let cs = getValueAt e i + c = Coord c' + drawColorString' cs (Coords (c + 10) 3) zeroCoords + ) $ map Frame [0..lastFrame] + + mapM_ + (\i@(Frame c') -> do + let cs = getValueAt e' i + c = Coord c' + drawColorString' cs (Coords (c + 10) 25) zeroCoords + ) $ map Frame [0..lastFrame'] + + mapM_ + (\i@(Frame c') -> do + let cs = getValueAt e'' i + c = Coord c' + drawColorString' cs (Coords (c + 20) 25) zeroCoords + ) $ map Frame [0..lastFrame''] + + mapM_ + (\i@(Frame c') -> do + let cs@(ColorString l) = getValueAt e''' i + (_,color) = head l + c = Coord c' + drawColorString' cs (Coords (c + 30) 25) zeroCoords + drawStr''' (show color) (Coords (c + 30) 35) zeroCoords + ) $ map Frame [0..lastFrame'''] + +drawColorString' :: (Draw e, MonadReader e m, MonadIO m) + => ColorString + -> Coords Pos + -> Coords Pos + -> m () +drawColorString' cs pos rs = + void (drawColorStr cs (translate pos rs)) + +drawStr''' :: (Draw e, MonadReader e m, MonadIO m) + => String + -> Coords Pos + -> Coords Pos + -> m (Coords Pos) +drawStr''' cs pos rs = + drawStr'' cs (translate pos rs) (LayeredColor black white) + + +drawStr'' :: (Draw e, MonadReader e m, MonadIO m) + => String + -> Coords Pos + -> LayeredColor + -> m (Coords Pos) +drawStr'' str pos color = + drawStr str pos color >> return (translateInDir Down pos) diff --git a/test/Test/Imj/Interpolation.hs b/test/Test/Imj/Interpolation.hs new file mode 100644 --- /dev/null +++ b/test/Test/Imj/Interpolation.hs @@ -0,0 +1,67 @@ + +module Test.Imj.Interpolation + ( testInterpolation + , testCoords + , testListCoords + , testInts + , testListInts + , testSuccessiveInts + , testClock ) where + +import Imj.Graphics.Math.Ease +import Imj.Geo.Discrete +import Imj.Graphics.Interpolation + +testInterpolation :: IO () +testInterpolation = mapM_ print testClock + +zipAll :: (DiscreteInterpolation a) => Evolution a -> Frame -> (a, Maybe Float) +zipAll e x = (getValueAt e x, getDeltaTimeToNextFrame e x) + + + +testCoords :: [(Coords Pos, Maybe Float)] +testCoords = + let from :: Coords Pos + from = Coords 0 0 + to = Coords 1 0 + d = distance from to + e = mkEvolutionEaseQuart (Successive [from, to]) 1 + in map (zipAll e . Frame) [0..pred d] + +testListCoords :: [([Coords Pos], Maybe Float)] +testListCoords = + let from = [Coords 0 0, (Coords 10 10 :: Coords Pos)] + to = [Coords 1 0, Coords 11 10] + d = distance from to + e = mkEvolutionEaseQuart (Successive [from, to]) 1 + in map (zipAll e . Frame) [0..pred d] + +testInts :: [(Int, Maybe Float)] +testInts = + let from = 0 + to = 20 + d = distance from to + e = mkEvolutionEaseQuart (Successive [from, to]) 1 + in map (zipAll e . Frame) [0..pred d] + +testListInts :: [([] Int, Maybe Float)] +testListInts = + let from = [0,13] + to = [1,11] + d = distance from to + e = mkEvolutionEaseQuart (Successive [from, to]) 1 + in map (zipAll e . Frame) [0..pred d] + +testSuccessiveInts :: [(Int, Maybe Float)] +testSuccessiveInts = + let s = Successive [3,7,9,5] + e = mkEvolutionEaseQuart s 1 + d = distanceSuccessive s + in map (zipAll e . Frame) [0..pred d] + +testClock :: [(Frame, Maybe Float)] +testClock = + let lastFrame = Frame 10 + (EaseClock clock) = mkEaseClock 1 lastFrame invQuartEaseInOut + in map (\f -> (f, getDeltaTimeToNextFrame clock f)) [0..lastFrame] diff --git a/test/Test/Imj/Timing.hs b/test/Test/Imj/Timing.hs new file mode 100644 --- /dev/null +++ b/test/Test/Imj/Timing.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Test.Imj.Timing where + +import Imj.Prelude +import Data.Time(secondsToDiffTime, picosecondsToDiffTime) +import Data.Time.Clock.System(SystemTime(..)) + +import Imj.Timing + +testTiming :: IO Bool +testTiming = do + testDiffTimeSecToMicros + testFloatSecondsToDiffTime + testAddSystemTime + testAddSystemTime2 + testAddSystemTime3 + testDiffSystemTime + testDiffSystemTime2 + testDiffSystemTime3 + return True + + +testDiffSystemTime :: IO () +testDiffSystemTime = do + let s1 = MkSystemTime 1 0 + s2 = MkSystemTime 2 0 + d = diffSystemTime s1 s2 + d' = diffSystemTime s2 s1 + when (d /= secondsToDiffTime (-1)) $ error $ "d = " ++ show d + when (d' /= secondsToDiffTime 1) $ error $ "d' = " ++ show d' + +testDiffSystemTime2 :: IO () +testDiffSystemTime2 = do + let s1 = MkSystemTime 1 1 + s2 = MkSystemTime 1 2 + d = diffSystemTime s1 s2 + d' = diffSystemTime s2 s1 + when (d /= picosecondsToDiffTime (-1000)) $ error $ "d = " ++ show d + when (d' /= picosecondsToDiffTime 1000) $ error $ "d' = " ++ show d' + +testDiffSystemTime3 :: IO () +testDiffSystemTime3 = do + let s1 = MkSystemTime 1 1 + s2 = MkSystemTime 2 2 + d = diffSystemTime s1 s2 + d' = diffSystemTime s2 s1 + when (d /= secondsToDiffTime (-1) + picosecondsToDiffTime (-1000)) $ error $ "d = " ++ show d + when (d' /= secondsToDiffTime 1 + picosecondsToDiffTime 1000) $ error $ "d' = " ++ show d' + +testAddSystemTime :: IO () +testAddSystemTime = do + let s = MkSystemTime 1 0 + (MkSystemTime seconds nanos) = addToSystemTime 1 s + (MkSystemTime seconds' nanos') = addToSystemTime (-1) s + when (seconds /= 2) $ error $ "seconds = " ++ show seconds + when (nanos /= 0) $ error $ "nanos = " ++ show nanos + when (seconds' /= 0) $ error $ "seconds' = " ++ show seconds' + when (nanos' /= 0) $ error $ "nanos' = " ++ show nanos' + + +testAddSystemTime2 :: IO () +testAddSystemTime2 = do + let s = MkSystemTime 1 999999999 + (MkSystemTime seconds nanos) = addToSystemTime (picosecondsToDiffTime 1000) s + (MkSystemTime seconds' nanos') = addToSystemTime (picosecondsToDiffTime (-1000)) s + when (seconds /= 2) $ error $ "seconds = " ++ show seconds + when (nanos /= 0) $ error $ "nanos = " ++ show nanos + when (seconds' /= 1) $ error $ "seconds' = " ++ show seconds' + when (nanos' /= 999999998) $ error $ "nanos' = " ++ show nanos' + +testAddSystemTime3 :: IO () +testAddSystemTime3 = do + let s = MkSystemTime 1 999999999 + (MkSystemTime seconds nanos) = addToSystemTime (picosecondsToDiffTime $ 1000000000000 + 1000) s + (MkSystemTime seconds' nanos') = addToSystemTime (picosecondsToDiffTime (-(1000000000000 + 1000))) s + when (seconds /= 3) $ error $ "seconds = " ++ show seconds + when (nanos /= 0) $ error $ "nanos = " ++ show nanos + when (seconds' /= 0) $ error $ "seconds' = " ++ show seconds' + when (nanos' /= 999999998) $ error $ "nanos' = " ++ show nanos' + +testFloatSecondsToDiffTime :: IO () +testFloatSecondsToDiffTime = do + let minusOneSecAsMicros = diffTimeSecToMicros $ floatSecondsToDiffTime (-1) + when (minusOneSecAsMicros /= -1000000) + $ error $ "minusOneSecAsMicros = " ++ show minusOneSecAsMicros + + let halfSecAsMicros = diffTimeSecToMicros $ floatSecondsToDiffTime 0.5 + when (halfSecAsMicros /= 500000) + $ error $ "halfSecAsMicros = " ++ show halfSecAsMicros + + let oneMicros = diffTimeSecToMicros $ floatSecondsToDiffTime 0.000001 + when (oneMicros /= 1) + $ error $ "oneMicros = " ++ show oneMicros + + let minusOneMicros = diffTimeSecToMicros $ floatSecondsToDiffTime $ -0.000001 + when (minusOneMicros /= -1) + $ error $ "minusOneMicros = " ++ show oneMicros + + +testDiffTimeSecToMicros :: IO () +testDiffTimeSecToMicros = do + let oneSecondAsMicros = diffTimeSecToMicros 1 + when (oneSecondAsMicros /= 1000000) + $ error $ "oneSecondAsMicros = " ++ show oneSecondAsMicros + + t <- getSystemTime + let zeroDiff = diffTimeSecToMicros $ diffSystemTime t t + when (zeroDiff /= 0) + $ error $ "zeroDiff = " ++ show zeroDiff diff --git a/test/Test/Imj/Vector.hs b/test/Test/Imj/Vector.hs new file mode 100644 --- /dev/null +++ b/test/Test/Imj/Vector.hs @@ -0,0 +1,86 @@ +module Test.Imj.Vector + ( testVector + ) where + +import Control.Monad(when) +import Prelude hiding (length, read) + +import Imj.Data.Vector.Unboxed.Mutable.Dynamic + +-- | returns 1 on success, else errors +testVector :: IO Bool +testVector = do + mapM_ testWithCapacity [0..28] + mapM_ testSort [0..300] + return True + +testSort :: Int -> IO Bool +testSort n = do + --print $ "sort " ++ show n + v <- new n + + mapM_ + (\val -> + pushBack v (-val) + ) [(0 :: Int)..pred n] + + -- verify values + mapM_ + (\idx -> do + val <- read v idx + when (val /= (-idx)) $ error $ "wrong value " ++ show (val,-idx) + ) [0..pred n] + + unstableSort v + + -- verify values after sort + mapM_ + (\idx -> do + val <- read v idx + when (val /= (-(n-1)+idx)) $ error $ "wrong value after sort" ++ show (val,idx) + ) [0..pred n] + + return True + +testWithCapacity :: Int -> IO Bool +testWithCapacity desiredCap = do + --print $ "capacity " ++ show desiredCap + v <- new desiredCap + let _m = v :: IOVector Int -- TODO is this the only way I can force the type? + l <- length v + when (0 /= l) $ error "initial length should be 0" + actualCap <- capacity v + when (actualCap /= desiredCap) $ error "desired capacity not reached" + clear v + capAfterClear <- capacity v + when (capAfterClear /= desiredCap) $ error "clear should keep capacity unchanged" + + -- pushback while remaining within the vector's capacity + mapM_ + (\val -> do + pushBack v val + curCap <- capacity v + when (curCap /= desiredCap) $ error "within capacity : pushback should not reallocate" + ) [0..pred desiredCap] + + -- the next pushback will double the capacity + mapM_ + (\val -> do + pushBack v val + curCap <- capacity v + when (curCap /= (1+2*desiredCap)) $ error "within capacity : pushback should have reallocated" + ) [desiredCap..pred $ 2*desiredCap] + + -- verify values + mapM_ + (\idx -> do + val <- read v idx + when (val /= idx) $ error "wrong value" + ) [0..pred desiredCap] + mapM_ + (\idx -> do + val <- read v idx + when (val /= idx) $ error "wrong value" + ) [desiredCap..pred $ 2*desiredCap] + + return True