dynamic-plot 0.1.2.0 → 0.1.3.0

raw patch · 3 files changed

+206/−75 lines, 3 filesdep ~lensdep ~manifoldsPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: lens, manifolds

API changes (from Hackage documentation)

Files

• Graphics/Dynamic/Plot/Internal/Types.hs +9/−0
• Graphics/Dynamic/Plot/R2.hs +194/−72
• dynamic-plot.cabal +3/−3

@@ -11,6 +11,7 @@ {-# LANGUAGE NoMonomorphismRestriction  #-} {-# LANGUAGE GADTs                      #-} {-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE MultiParamTypeClasses      #-} {-# LANGUAGE ScopedTypeVariables        #-} {-# LANGUAGE RecordWildCards            #-} {-# LANGUAGE TupleSections              #-}@@ -106,6 +107,10 @@   (.+~^) = (^+^) instance PseudoAffine R2 where   p.-~.q = pure(p^-^q)+instance LocallyCoercible R2 (R,R) where+  locallyTrivialDiffeomorphism v = (v^._x, v^._y)+instance LocallyCoercible (R,R) R2 where+  locallyTrivialDiffeomorphism = DiaTypes.r2  instance AffineSpace P2 where   type Diff P2 = R2@@ -119,6 +124,10 @@   (.+~^) = (.+^) instance PseudoAffine P2 where   p.-~.q = pure(p.-.q)+instance LocallyCoercible P2 (R,R) where+  locallyTrivialDiffeomorphism v = (v^._x, v^._y)+instance LocallyCoercible (R,R) P2 where+  locallyTrivialDiffeomorphism = DiaTypes.p2   

@@ -97,11 +97,13 @@   import Data.List (foldl', sort, sortBy, intercalate, isPrefixOf, isInfixOf, find, zip4)+import qualified Data.List.NonEmpty as NE import qualified Data.Vector as Arr import Data.Maybe import Data.Semigroup import Data.Default import Data.Foldable (fold, foldMap)+import qualified Data.Foldable as Hask import Data.Function (on) import Data.Ord (comparing) @@ -113,6 +115,7 @@ import Data.Function.Differentiable import Data.Manifold.Types import Data.Manifold.TreeCover+import Data.Manifold.Web import qualified Data.Map.Lazy as Map  import Data.Tagged@@ -359,15 +362,22 @@ --   Beware that this will always slow down the performance when the list is large; --   there is no &#201c;statistic optimisation&#201d; as in 'tracePlot'. lineSegPlot :: [(Double, Double)] -> DynamicPlottable-lineSegPlot ps = def {-               relevantRange_x = atLeastInterval' $ foldMap (pure . spInterval . fst) ps-             , relevantRange_y = atLeastInterval' $ foldMap (pure . spInterval . snd) ps+lineSegPlot ps'+    | null ps        = mempty { isTintableMonochromic = True }+    | otherwise      = def {+               relevantRange_x = atLeastInterval' $ foldMap (pure . spInterval . fst) (concat ps)+             , relevantRange_y = atLeastInterval' $ foldMap (pure . spInterval . snd) (concat ps)              , isTintableMonochromic = True              , axesNecessity = 1              , dynamicPlot = plot }- where plot (GraphWindowSpecR2{..}) = mkPlot (trace ps)+ where plot (GraphWindowSpecR2{..}) = mkPlot (foldMap trace ps)         where trace (p:q:ps) = simpleLine (Dia.p2 p) (Dia.p2 q) <> trace (q:ps)               trace _ = mempty+       ps = filter ((>1) . length) $ safeSeg ps'+       safeSeg [] = [[]]+       safeSeg ((x,y):l) | x==x && not (isInfinite x) && y==y && not (isInfinite y)+                           = case safeSeg l of { h:r -> ((x,y):h):r }+                         | otherwise  = [] : safeSeg l     @@ -425,7 +435,6 @@ rPCMPlot = plot . recursivePCM (PCMRange (0 :: Double) 1)  - instance Plottable (Shade P2) where   plot shade = def {                 relevantRange_x = atLeastInterval xRange@@ -434,13 +443,114 @@               , axesNecessity = 1               , dynamicPlot = plot               }-   where plot grWS@(GraphWindowSpecR2{..}) = mkPlot $ foldMap axLine eigVs -          where (pixWdth, pixHght) = pixelDim grWS-                axLine eigV = simpleLine (ctr .-~^ eigV) (ctr .+~^ eigV)+   where plot _ = mkPlot $ foldMap axLine eigVs +          where axLine eigV = simpleLine (ctr .-~^ eigV) (ctr .+~^ eigV)          (xRange,yRange) = shadeExtends shade          ctr = shade^.shadeCtr          eigVs = eigenSpan $ shade^.shadeExpanse +instance Plottable (Shade (R,R)) where+  plot sh = plot (coerceShade sh :: Shade P2)++instance Plottable (Shade' (R,R)) where+  plot shade = def {+                isTintableMonochromic = True+              , axesNecessity = 1+              , dynamicPlot = plot+              }+   where plot _ = mkPlot $ Dia.circle 1+                            & Dia.scaleX w₁ & Dia.scaleY w₂+                            & Dia.rotate ϑ+                            & Dia.opacity 0.2+                            & Dia.moveTo ctr+         ctr = Dia.p2 $ shade^.shadeCtr+         [ev₁@(e₁x,e₁y),ev₂] = eigenSpan' $ shade^.shadeNarrowness+         ϑ = atan2 e₁y e₁x  Dia.@@ Dia.rad+         w₁ = recip $ magnitude ev₁; w₂ = recip $ magnitude ev₂+         +instance Plottable (Shade' P2) where+  plot sh = plot (coerceShade sh :: Shade' (R,R))+++instance Plottable (Shaded ℝ ℝ) where+  plot tr | length trivs' >= 2+          = def { relevantRange_x = atLeastInterval $ Interval xmin xmax+                , relevantRange_y = atLeastInterval $ Interval ymin ymax+                , isTintableMonochromic = True+                , axesNecessity = 1+                , dynamicPlot = plot+                }+   where plot grWS@(GraphWindowSpecR2{..}) = mkPlot $+                            foldMap parallelogram trivs+                         <> (foldMap (singlePointFor grWS) leafPoints+                               -- & Dia.dashingO [2,3] 0+                               & Dia.opacity 0.4 )+          where parallelogram ((x,δx), ((y,δy), j))+                    = lLoop [ (x+δx)^&(y+δy+jδx), (x-δx)^&(y+δy-jδx)+                            , (x-δx)^&(y-δy-jδx), (x+δx)^&(y-δy+jδx) ]+                         & Dia.strokeLocLoop+                         & Dia.opacity 0.3+                 where jδx = j $ δx+         trivs' = sortBy (comparing fst) $ stiAsIntervalMapping tr+         trivs = NE.fromList $ ccδs trivs'+          where ccδs [(x, yq), (x', yq')] = [((x,δx),yq), ((x',δx),yq')]+                 where δx = (x' - x)/2+                ccδs [(x, yq), (x', yq'), (x'', yq'')]+                         = [((x,δx),yq), ((x',δx),yq'), ((x'',δx),yq'')]+                 where δx = (x'' - x)/4+                ccδs ((x, yq) : xyqs@((x', yq') : (x'', _) : _))+                         = ((x,δx),yq) : ((x',δx),yq') : tail (ccδs xyqs)+                 where δx = (x'' - x)/4+         [xmin, ymin, xmax, ymax]+            = [minimum, maximum]<*>[_topological<$>allLeaves, _untopological<$>allLeaves]+         lLoop ps@(p:_) = Dia.fromVertices $ ps++[p]+         leafPoints = sortBy (comparing (^._x))+                         $ (\(x`WithAny`y) -> y^&x) <$> allLeaves+         allLeaves = onlyLeaves tr+  plot _ = def++instance Plottable (PointsWeb ℝ (Shade' ℝ)) where+  plot web | length locals >= 2+          = def { relevantRange_x = atLeastInterval $ Interval xmin xmax+                , relevantRange_y = atLeastInterval $ Interval ymin ymax+                , isTintableMonochromic = True+                , axesNecessity = 1+                , dynamicPlot = plot+                }+   where plot grWS@(GraphWindowSpecR2{..}) = mkPlot $+                            foldMap parallelogram trivs+          where parallelogram ((x,δx), ((y,δy), j))+                    = lLoop [ (x+δx)^&(y+δy+jδx), (x-δx)^&(y+δy-jδx)+                            , (x-δx)^&(y-δy-jδx), (x+δx)^&(y-δy+jδx) ]+                         & Dia.strokeLocLoop+                         & Dia.opacity 0.3+                 where jδx = j $ δx+         +         trivs :: [((ℝ, Diff ℝ), ((ℝ, Diff ℝ), LocalLinear ℝ ℝ))]+         trivs = map mkTriv locals+          where mkTriv ((xc,Shade' yc yce), [(xo, Shade' yo _)])+                       = ( (xc, xo-xc)+                         , ( (yc, metricAsLength yce)+                           , denseLinear $ \δx -> δx * (yo-yc)/(xo-xc) ) )+                mkTriv ((xc,Shade' yc yce), [(xl, Shade' yl _), (xr, Shade' yr _)])+                       = ( (xc, δxg)+                         , ( (yc, metricAsLength yce)+                           , denseLinear $ \δx -> δx * η ) )+                 where δxg = (xr - xl)/2+                       η = (yr - yl)/(2*δxg)+                mkTriv (_,l) = error $ "Encountered point in web with "+                                ++show(length l)++" neighbours. Any point in 1D "+                                ++"should have either one or two neighbours!"+         +         lLoop ps@(p:_) = Dia.fromVertices $ ps++[p]+         +         [xmin, ymin, xmax, ymax]+            = [minimum, maximum]<*>[fst.fst<$>locals, (^.shadeCtr).snd.fst<$>locals]+         +         locals :: [((ℝ, Shade' ℝ), [(ℝ, Shade' ℝ)])]+         locals = Hask.toList $ localFocusWeb web+  plot _ = def+ instance Plottable (SimpleTree P2) where   plot (GenericTree Nothing) = plot ([] :: [SimpleTree P2])   plot (GenericTree (Just (ctr, root)))@@ -461,14 +571,27 @@                             in (xmin ... xmax, ymin ... ymax)           where gPts (GenericTree brchs) = foldr (\(c,b) r -> c : gPts b ++ r) [] brchs          tree = GenericTree [(ctr,root)]- instance Plottable (Trees P2) where   plot (GenericTree ts) = plot $ (GenericTree . Just) <$> ts +instance Plottable (SimpleTree (R,R)) where+  plot = plot . fmap (\(x,y) -> DiaTypes.p2 (x,y))+instance Plottable (Trees (R,R)) where+  plot (GenericTree ts) = plot $ (GenericTree . Just) <$> ts++instance Plottable (SimpleTree (R`WithAny`R)) where+  plot = plot . fmap (\(WithAny y x) -> DiaTypes.p2 (x,y))+instance Plottable (Trees (R`WithAny`R)) where+  plot (GenericTree ts) = plot $ (GenericTree . Just) <$> ts+ pixelDim :: GraphWindowSpecR2 -> (R, R) pixelDim grWS = ( graphWindowWidth grWS / fromIntegral (xResolution grWS)                 , graphWindowHeight grWS / fromIntegral (yResolution grWS) ) +singlePointFor :: GraphWindowSpecR2 -> P2 -> PlainGraphicsR2+singlePointFor spec = Dia.place circ+ where (pxw,pxh) = pixelDim spec+       circ = Dia.circle 1 & Dia.scaleX pxw & Dia.scaleY pxh   type GraphWindowSpec = GraphWindowSpecR2@@ -598,12 +721,12 @@ --   Invoke e.g. from @ghci +RTS -N4@ to benefit from this. --    --   ATTENTION: the window may sometimes freeze, especially when displaying ---   complicated functions with 'diffableFnPlot` from ghci. This is apparently+--   complicated functions with 'fnPlot` from ghci. This is apparently --   a kind of deadlock problem with one of the C libraries that are invoked,---   in particular, 'diffableFnPlot' makes heavy use of <http://hackage.haskell.org/package/hmatrix hmatrix>+--   in particular, 'fnPlot' makes heavy use of <http://hackage.haskell.org/package/hmatrix hmatrix> --   and thus <http://www.gnu.org/software/gsl/ GSL>.---   At the moment, we can recommend no better solution than to abort and restart ghci,---   if this occurs.+--   At the moment, we can recommend no better solution than to abort and restart ghci+--   (or what else you use – iHaskell kernel, process, ...) if this occurs. plotWindow :: [DynamicPlottable] -> IO GraphWindowSpec plotWindow [] = plotWindow [dynamicAxes] plotWindow graphs' = do@@ -638,6 +761,8 @@        GTK.initGUI    window <- GTK.windowNew+   +   mouseAnchor <- newIORef Nothing                      refreshDraw <- do        drawA <- GTK.drawingAreaNew@@ -657,31 +782,59 @@                 BGTK.renderToGtk drawWindow $ scaledDia                 return True        +       GTK.on drawA GTK.buttonPressEvent . Event.tryEvent $ do+            Event.eventButton >>= guard.(==defaultDragButton)+            anchXY <- Event.eventCoordinates+            liftIO . writeIORef mouseAnchor $ Just anchXY+       GTK.on drawA GTK.buttonReleaseEvent . Event.tryEvent $ do+            Event.eventButton >>= guard.(==defaultDragButton)+            liftIO . writeIORef mouseAnchor $ Nothing+       +       GTK.on drawA GTK.motionNotifyEvent . Event.tryEvent $ do+          liftIO (readIORef mouseAnchor) >>= \case+             Just (oldX,oldY) -> do+                (mvX,mvY) <- Event.eventCoordinates+                (canvasX,canvasY) <- liftIO $ GTK.widgetGetSize drawA+                let ηX = (oldX-mvX) / fromIntegral canvasX+                    ηY = (mvY-oldY) / fromIntegral canvasY+                liftIO . modifyIORef viewTgt $ \view@GraphWindowSpecR2{..} ->+                    let w = rBound - lBound+                        h = tBound - bBound+                    in view{ lBound = lBound + w * ηX+                           , rBound = rBound + w * ηX+                           , tBound = tBound + h * ηY+                           , bBound = bBound + h * ηY+                           }+                liftIO . modifyIORef mouseAnchor . fmap $ const (mvX,mvY)+             Nothing -> mzero+       GTK.widgetAddEvents drawA [GTK.ButtonMotionMask]+               GTK.on drawA GTK.scrollEvent . Event.tryEvent $ do                 (canvasX,canvasY) <- liftIO $ GTK.widgetGetSize drawA                 (scrollX,scrollY) <- Event.eventCoordinates                 let (rcX,rcY) = ( scrollX*2 / fromIntegral canvasX - 1                                 , 1 - scrollY*2 / fromIntegral canvasY )                 scrollD <- Event.eventScrollDirection-                case defaultScrollBehaviour scrollD of-                   ScrollZoomIn  -> liftIO $ do-                     modifyIORef viewTgt $ \view@GraphWindowSpecR2{..}-                         -> let w = rBound - lBound-                                h = tBound - bBound-                            in view{ lBound = lBound + w * (rcX + 1)^2 * scrollZoomStrength-                                   , rBound = rBound - w * (rcX - 1)^2 * scrollZoomStrength-                                   , tBound = tBound - h * (rcY - 1)^2 * scrollZoomStrength-                                   , bBound = bBound + h * (rcY + 1)^2 * scrollZoomStrength-                                   }-                   ScrollZoomOut -> liftIO $ do-                     modifyIORef viewTgt $ \view@GraphWindowSpecR2{..}-                         -> let w = rBound - lBound-                                h = tBound - bBound-                            in view{ lBound = lBound - w * (rcX - 1)^2 * scrollZoomStrength-                                   , rBound = rBound + w * (rcX + 1)^2 * scrollZoomStrength-                                   , tBound = tBound + h * (rcY + 1)^2 * scrollZoomStrength-                                   , bBound = bBound - h * (rcY - 1)^2 * scrollZoomStrength-                                   }+                liftIO . modifyIORef viewTgt $ \view@GraphWindowSpecR2{..} ->+                  let w = rBound - lBound+                      h = tBound - bBound+                      ηl = (rcX + 1)^2/4; ηr = (rcX - 1)^2/4+                      ηb = (rcY + 1)^2/4; ηt = (rcY - 1)^2/4+                      ηh = (1-ηt) * (1-ηb) + ηl + ηr+                      ηv = (1-ηl) * (1-ηr) + ηt + ηb+                   in case defaultScrollBehaviour scrollD of+                        ScrollZoomIn -> view{+                            lBound = lBound + w * ηl * ηh * scrollZoomStrength+                          , rBound = rBound - w * ηr * ηh * scrollZoomStrength+                          , tBound = tBound - h * ηt * ηv * scrollZoomStrength+                          , bBound = bBound + h * ηb * ηv * scrollZoomStrength+                          }+                        ScrollZoomOut -> view{+                            lBound = lBound - w * ηr * ηh * scrollZoomStrength+                          , rBound = rBound + w * ηl * ηh * scrollZoomStrength+                          , tBound = tBound + h * ηb * ηv * scrollZoomStrength+                          , bBound = bBound - h * ηt * ηv * scrollZoomStrength+                          }                                                        @@ -728,11 +881,7 @@    t₀ <- getCurrentTime    lastFrameTime <- newIORef t₀    -   let minKeyImpact = 0.05    -   keyImpactState <- newIORef $ Map.fromList [ (ka, (t₀, minKeyImpact)) | ka<-[MoveLeft .. ZoomOut_y] ]-   -       let refreshScreen = do            currentView@(GraphWindowSpecR2{..}) <- readIORef viewState            let normaliseView :: PlainGraphicsR2 -> PlainGraphicsR2@@ -797,15 +946,6 @@            -- GTK.pollEvents            return True    -   let keyImpact key = do-           t <- getCurrentTime-           Just (_, impact) <- fmap (Map.lookup key) $ readIORef keyImpactState-           modifyIORef keyImpactState $ Map.adjust ( \(t₁, p)-                       -> (t, min 1 $ ( (p - minKeyImpact) * (exp . (*3) . realToFrac $ diffUTCTime t₁ t)-                                       + minKeyImpact ) * 2 )-                   ) key-           return impact-       GTK.onDestroy window $ do         (readIORef graphs >>=) . mapM_  -- cancel remaining threads            $ \(_, GraphViewState{..}) -> cancel realtimeView >> cancel nextTgtView@@ -825,12 +965,17 @@   where (xRange, yRange) = foldMap (relevantRange_x &&& relevantRange_y) graphs         ((l,r), (b,t)) = ( xRange `dependentOn` yRange                          , yRange `dependentOn` xRange )+        +        dependentOn :: RangeRequest R -> RangeRequest R -> (R,R)         MustBeThisRange (Interval a b) `dependentOn` _ = (a,b)         OtherDimDependantRange ξ `dependentOn` MustBeThisRange i            = addMargin . defRng . ξ $ pure i         OtherDimDependantRange ξ `dependentOn` OtherDimDependantRange υ            = addMargin . defRng . ξ . pure . defRng $ υ mempty-        defRng = Interval (-1) 1 `option` id+        +        defRng (Option (Just (Interval a b))) | b>a     +                  = Interval a b+        defRng _  = Interval (-1) 1   -- ad-hoc hack to catch NaNs etc..         addMargin (Interval a b) = (a - q, b + q)             where q = (b - a) / 6   @@ -847,36 +992,13 @@ defaultScrollBehaviour Event.ScrollUp = ScrollZoomIn defaultScrollBehaviour Event.ScrollDown = ScrollZoomOut +defaultDragButton :: Event.MouseButton+defaultDragButton = Event.MiddleButton+ scrollZoomStrength :: Double scrollZoomStrength = 1/20  -data KeyAction = MoveLeft-               | MoveRight-               | MoveUp-               | MoveDown-               | ZoomIn_x-               | ZoomOut_x-               | ZoomIn_y-               | ZoomOut_y-               | QuitProgram-   deriving (Eq, Ord, Enum)--defaultKeyMap :: GTK.KeyVal -> Maybe KeyAction--- defaultKeyMap (GLFW.SpecialKey GLFW.UP   ) = Just MoveUp--- defaultKeyMap (GLFW.SpecialKey GLFW.DOWN ) = Just MoveDown--- defaultKeyMap (GLFW.SpecialKey GLFW.LEFT ) = Just MoveLeft--- defaultKeyMap (GLFW.SpecialKey GLFW.RIGHT) = Just MoveRight--- defaultKeyMap (GLFW.CharKey 'K') = Just MoveUp--- defaultKeyMap (GLFW.CharKey 'J') = Just MoveDown--- defaultKeyMap (GLFW.CharKey 'H') = Just MoveLeft--- defaultKeyMap (GLFW.CharKey 'L') = Just MoveRight--- defaultKeyMap (GLFW.CharKey 'B') = Just ZoomIn_x--- defaultKeyMap (GLFW.CharKey 'N') = Just ZoomOut_x--- defaultKeyMap (GLFW.CharKey 'I') = Just ZoomIn_y--- defaultKeyMap (GLFW.CharKey 'O') = Just ZoomOut_y--- defaultKeyMap (GLFW.SpecialKey GLFW.ESC) = Just QuitProgram-defaultKeyMap _ = Nothing   

@@ -1,5 +1,5 @@ Name:                dynamic-plot-Version:             0.1.2.0+Version:             0.1.3.0 Category:            graphics Synopsis:            Interactive diagram windows Description:         Haskell excels at handling data like continuous functions@@ -60,8 +60,8 @@                      , gtk > 0.10 && < 0.15                      , glib                      , colour >= 2 && < 3-                     , manifolds >= 0.1.6.3 && < 0.1.7-                     , lens < 4.12.4+                     , manifolds >= 0.2.2 && < 0.2.3+                     , lens < 4.15   Other-Extensions:  FlexibleInstances                      , TypeFamilies                      , FlexibleContexts