packages feed

imj-base (empty) → 0.1.0.2

raw patch · 79 files changed

+6420/−0 lines, 79 filesdep +ansi-terminaldep +basedep +imj-basesetup-changed

Dependencies added: ansi-terminal, base, imj-base, imj-prelude, mtl, primitive, random, terminal-size, text, time, vector, vector-algorithms

Files

+ CHANGELOG.md view
@@ -0,0 +1,8 @@+# Changelog++This project adheres to [Haskell PVP](https://pvp.haskell.org/).+++## 0.1.0.2 [2018-01-01]++- Initial release
+ LICENSE view
@@ -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.
+ README.md view
@@ -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`.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ example/Main.hs view
@@ -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
+ imj-base.cabal view
@@ -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
+ src/Imj/Data/Vector/Unboxed/Mutable/Dynamic.hs view
@@ -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 #-}
+ src/Imj/Example/DeltaRender/FromMonadIO.hs view
@@ -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
+ src/Imj/Example/DeltaRender/FromMonadReader.hs view
@@ -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
+ src/Imj/Example/SequentialTextTranslationsAnchored.hs view
@@ -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
+ src/Imj/GameItem/Weapon/Laser.hs view
@@ -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)
+ src/Imj/GameItem/Weapon/Laser/Types.hs view
@@ -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
+ src/Imj/Geo/Continuous.hs view
@@ -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+<https://en.wikipedia.org/wiki/Equations_of_motion equation [2] in "Constant linear acceleration in any direction">:++\[ \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
+ src/Imj/Geo/Continuous/Conversion.hs view
@@ -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))
+ src/Imj/Geo/Continuous/Types.hs view
@@ -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)
+ src/Imj/Geo/Discrete.hs view
@@ -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+           <https://en.wikipedia.org/wiki/Bresenham%27s_line_algorithm draw a line on a 2d grid>.++           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
+ src/Imj/Geo/Discrete/Bresenham.hs view
@@ -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)
+ src/Imj/Geo/Discrete/Bresenham3.hs view
@@ -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))
+ src/Imj/Geo/Discrete/Resample.hs view
@@ -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)
+ src/Imj/Geo/Discrete/Types.hs view
@@ -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+          []
+ src/Imj/Geo/Types.hs view
@@ -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
+ src/Imj/Graphics/Class.hs view
@@ -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
+ src/Imj/Graphics/Class/Colorable.hs view
@@ -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 ()
+ src/Imj/Graphics/Class/DiscreteColorableMorphing.hs view
@@ -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 ()
+ src/Imj/Graphics/Class/DiscreteDistance.hs view
@@ -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'
+ src/Imj/Graphics/Class/DiscreteInterpolation.hs view
@@ -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'
+ src/Imj/Graphics/Class/DiscreteMorphing.hs view
@@ -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
+ src/Imj/Graphics/Class/Draw.hs view
@@ -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
+ src/Imj/Graphics/Class/Drawable.hs view
@@ -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 ()
+ src/Imj/Graphics/Class/HasLayeredColor.hs view
@@ -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
+ src/Imj/Graphics/Class/Render.hs view
@@ -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 ()
+ src/Imj/Graphics/Color.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE NoImplicitPrelude #-}++module Imj.Graphics.Color+  (+    -- * 8-bits colors+    {- | There are+    <https://en.wikipedia.org/wiki/ANSI_escape_code#Colors several types of colors we can use to draw in a terminal>.+    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+-- <https://jonasjacek.github.io/colors/ xterm interprets 8bit rgb colors>+xtermMapRGB8bitComponent :: Word8+                         -- ^ input values are in+                         -- <https://en.wikipedia.org/wiki/ANSI_escape_code#Colors [0..5]>+                         -> Word8+                         -- ^ output is in range [0..255]+xtermMapRGB8bitComponent 0 = 0+xtermMapRGB8bitComponent n = 55 + n * 40++-- | How+-- <https://jonasjacek.github.io/colors/ xterm interprets 8bit grayscale colors>+xtermMapGray8bitComponent :: Word8+                          -- ^ input values are in+                          -- <https://en.wikipedia.org/wiki/ANSI_escape_code#Colors [0..23]>+                          -> Word8+                          -- ^ output is in range [0..255]+xtermMapGray8bitComponent v = 8 + 10 * v+-}
+ src/Imj/Graphics/Color/Types.hs view
@@ -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+-- <https://en.wikipedia.org/wiki/ANSI_escape_code#8-bit ANSI 8-bit colors>+--+-- 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+-- <https://en.wikipedia.org/wiki/ANSI_escape_code#8-bit ANSI 8-bit colors>+--+-- 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+-- <https://vt100.net/docs/vt510-rm/SGR.html SGR codes>.+color8FgSGRToCode :: Color8 Foreground -> [Int]+color8FgSGRToCode (Color8 c) =+  [38, 5, fromIntegral c]++-- | Converts a 'Color8' 'Background' to corresponding+-- <https://vt100.net/docs/vt510-rm/SGR.html SGR codes>.+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+--  <https://en.wikipedia.org/wiki/ANSI_escape_code#Colors here>.+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
+ src/Imj/Graphics/Interpolation.hs view
@@ -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
+ src/Imj/Graphics/Interpolation/Evolution.hs view
@@ -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
+ src/Imj/Graphics/Interpolation/SequentiallyInterpolatedList.hs view
@@ -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')
+ src/Imj/Graphics/Math/Ease.hs view
@@ -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 <http://gizma.com/easing/ 4th order ease in-out function> \( 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
+ src/Imj/Graphics/Render.hs view
@@ -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+  <https://en.wikipedia.org/wiki/Screen_tearing screen tearing effect>.+  -}+    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+@++<https://github.com/OlivierSohn/hamazed/blob/f38901ba9e33450cae1425c26fd55bd7b171c5ba/imj-game-hamazed/src/Imj/Game/Hamazed/Env.hs This example>+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(..))
+ src/Imj/Graphics/Render/Delta.hs view
@@ -0,0 +1,215 @@+{-# OPTIONS_HADDOCK prune #-}++{-# LANGUAGE NoImplicitPrelude #-}++{-|+The purpose of this module is to render games and animations in the terminal+without <https://en.wikipedia.org/wiki/Screen_tearing screen tearing>.++It supports <https://en.wikipedia.org/wiki/ANSI_escape_code#8-bit 8-bit Colors>+and <http://www.unicode.org/ Unicode> characters.++In short, <https://en.wikipedia.org/wiki/Screen_tearing screen tearing>+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+<https://github.com/OlivierSohn/hamazed/blob/f38901ba9e33450cae1425c26fd55bd7b171c5ba/imj-base/src/Imj/Example/DeltaRender/FromMonadIO.hs this example>):++    @+    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+<https://github.com/OlivierSohn/hamazed/blob/f38901ba9e33450cae1425c26fd55bd7b171c5ba/imj-base/src/Imj/Example/DeltaRender/FromMonadReader.hs this example>):++    @+    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+<https://github.com/OlivierSohn/hamazed/blob/f38901ba9e33450cae1425c26fd55bd7b171c5ba/imj-game-hamazed/src/Imj/Game/Hamazed/Env.hs this example>):++    * 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++<https://en.wikipedia.org/wiki/Screen_tearing 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+<https://github.com/OlivierSohn/hamazed hamazed>,+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+<https://github.com/ibraimgm Rafael Ibraim> took when+<https://gist.github.com/ibraimgm/40e307d70feeb4f117cd writing this code> 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.++<https://www.reddit.com/r/haskellquestions/comments/7i6hi5/optimizing_memory_usage_array_of_unboxed_values/ These answers on reddit>+helped in the process.++I use Vectors of unpacked 'Word64' (<https://wiki.haskell.org/GHC/Memory_Footprint the most efficient Haskell type in terms of "information quantity / memory usage" ratio>)+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 <http://hackage.haskell.org/package/vector-algorithms-0.7.0.1/docs/Data-Vector-Algorithms-Intro.html sorting>+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
+ src/Imj/Graphics/Render/Delta/Buffers.hs view
@@ -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)
+ src/Imj/Graphics/Render/Delta/Buffers/Dimensions.hs view
@@ -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)
+ src/Imj/Graphics/Render/Delta/Cell.hs view
@@ -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
+ src/Imj/Graphics/Render/Delta/Cells.hs view
@@ -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) ' '
+ src/Imj/Graphics/Render/Delta/Clear.hs view
@@ -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)
+ src/Imj/Graphics/Render/Delta/Console.hs view
@@ -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
+ src/Imj/Graphics/Render/Delta/DefaultPolicies.hs view
@@ -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
+ src/Imj/Graphics/Render/Delta/Draw.hs view
@@ -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
+ src/Imj/Graphics/Render/Delta/Env.hs view
@@ -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)
+ src/Imj/Graphics/Render/Delta/Flush.hs view
@@ -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.+-}
+ src/Imj/Graphics/Render/Delta/Internal/Types.hs view
@@ -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
+ src/Imj/Graphics/Render/Delta/Types.hs view
@@ -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)
+ src/Imj/Graphics/Render/FromMonadReader.hs view
@@ -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')
+ src/Imj/Graphics/Render/Naive.hs view
@@ -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+<https://en.wikipedia.org/wiki/Screen_tearing screen tearing> 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' #-}
+ src/Imj/Graphics/Text/Alignment.hs view
@@ -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
+ src/Imj/Graphics/Text/Animation.hs view
@@ -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
+ src/Imj/Graphics/Text/ColorString.hs view
@@ -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
+ src/Imj/Graphics/Text/ColorString/Interpolation.hs view
@@ -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"
+ src/Imj/Graphics/UI/Animation.hs view
@@ -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
+ src/Imj/Graphics/UI/Colored.hs view
@@ -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 #-}
+ src/Imj/Graphics/UI/RectContainer.hs view
@@ -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
+ src/Imj/Graphics/UI/RectContainer/MorphParallel4.hs view
@@ -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)
+ src/Imj/Input.hs view
@@ -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
+ src/Imj/Input/Blocking.hs view
@@ -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)
+ src/Imj/Input/NonBlocking.hs view
@@ -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
+ src/Imj/Input/Types.hs view
@@ -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
+ src/Imj/Iteration.hs view
@@ -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
+ src/Imj/Physics/Discrete.hs view
@@ -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
+ src/Imj/Physics/Discrete/Collision.hs view
@@ -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
+ src/Imj/Physics/Discrete/Types.hs view
@@ -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)
+ src/Imj/Threading.hs view
@@ -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+       <http://zguide.zeromq.org/hs:interrupt this approach> 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
+ src/Imj/Timing.hs view
@@ -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
+ src/Imj/Util.hs view
@@ -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
+ test/Spec.hs view
@@ -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
+ test/Test/Imj/Bresenham3.hs view
@@ -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)
+ test/Test/Imj/Ease.hs view
@@ -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)
+ test/Test/Imj/InterpolatedColorString.hs view
@@ -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)
+ test/Test/Imj/Interpolation.hs view
@@ -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]
+ test/Test/Imj/Timing.hs view
@@ -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
+ test/Test/Imj/Vector.hs view
@@ -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