diff --git a/Graphics/Dynamic/Plot/Internal/Types.hs b/Graphics/Dynamic/Plot/Internal/Types.hs --- a/Graphics/Dynamic/Plot/Internal/Types.hs +++ b/Graphics/Dynamic/Plot/Internal/Types.hs @@ -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 diff --git a/Graphics/Dynamic/Plot/R2.hs b/Graphics/Dynamic/Plot/R2.hs --- a/Graphics/Dynamic/Plot/R2.hs +++ b/Graphics/Dynamic/Plot/R2.hs @@ -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 Éc;statistic optimisationÉd; 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 +-- in particular, 'fnPlot' makes heavy use of -- and thus . --- 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 diff --git a/dynamic-plot.cabal b/dynamic-plot.cabal --- a/dynamic-plot.cabal +++ b/dynamic-plot.cabal @@ -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