hashirama/metabrush
1
0
Fork 0
mirror of https://gitlab.com/sheaf/metabrush.git synced 2024-11-05 14:53:37 +00:00
Code Issues Actions Projects Releases Wiki Activity

switch to using eigen instead of hmatrix

Browse source
This commit is contained in:
sheaf 2022-06-17 16:21:52 +02:00
parent 4e15380c7e
commit c80fdac30a
10 changed files with 113 additions and 43 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
MetaBrush.cabal
View file

@ -32,7 +32,7 @@ common common
build-depends:
base
>= 4.13 && < 4.17
>= 4.16 && < 4.20
, acts
^>= 0.3.1.0
, containers
@ -143,8 +143,8 @@ library splines
build-depends:
bifunctors
>= 5.5.4 && < 5.6
, hmatrix
^>= 0.20.0.0
, eigen
^>= 3.3.7.0
, parallel
^>= 3.2.2.0
, prim-instances

1
app/Main.hs
View file

@ -1,3 +1,4 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}

9
cabal.project
View file

@ -19,6 +19,12 @@ source-repository-package
tag: e9268cd5ea31322220c0847f2fdce968789693b4
subdir: packages/base
-- GHC compat fixes for records-sop
source-repository-package
type: git
location: https://github.com/kosmikus/records-sop
tag: abab99b4b870fce55e81dd03d4e41fb50502ca4e
package hmatrix
ghc-options: "-w"
flags: +openblas
@ -29,3 +35,6 @@ source-repository-package
subdir: large-generics
large-anon
tag: acb837a9a4c22cea1abf552b47f9d3bf5af2fbdf
package *
ghc-options: "-finfo-table-map" "-fdistinct-constructor-tables"

30
shell.nix Normal file
View file

@ -0,0 +1,30 @@
let np = import <nixpkgs> {};
in with np; np.mkShell { packages =
[ cabal-install
zlib
pkg-config
gobject-introspection
gtk4
pcre
cairo
glib
atk
util-linux
libselinux
libsepol
xorg.libXdmcp
libthai
libdatrie
epoxy
fribidi
xorg.libXi
xorg.libXrandr
xorg.libXcursor
xorg.libXdamage
xorg.libXinerama
libxkbcommon ];
shellHook = ''
export LC_ALL=C.UTF-8
export XDG_DATA_DIRS=${gsettings-desktop-schemas}/share/gsettings-schemas/${gsettings-desktop-schemas.name}:${gtk4}/share/gsettings-schemas/${gtk4.name}:$XDG_DATA_DIRS
'';
}

40
src/app/MetaBrush/Action.hs
View file

@ -267,22 +267,23 @@ instance HandleAction OpenFolder where
GTK.nativeDialogShow fileChooser
void $ GTK.afterNativeDialogResponse fileChooser \ response -> do
when ( response == fromIntegral ( fromEnum GTK.ResponseTypeAccept ) ) do
folder <- GTK.fileChooserGetFile fileChooser
mbFolderPath <- GIO.fileGetPath folder
for_ mbFolderPath \ folderPath -> do
exists <- doesDirectoryExist folderPath
when exists do
filePaths <- listDirectory folderPath
for_ filePaths \ filePath -> when ( takeExtension filePath == ".mb" ) do
mbDoc <- loadDocument uniqueSupply ( folderPath </> filePath )
case mbDoc of
Left errMessage -> warningDialog window filePath errMessage
Right doc -> do
let
newDocHist :: DocumentHistory
newDocHist = newHistory doc
newFileTab uiElts vars ( Just newDocHist ) tabLoc
updateHistoryState uiElts ( Just newDocHist )
mbFolder <- GTK.fileChooserGetFile fileChooser
for_ mbFolder \ folder -> do
mbFolderPath <- GIO.fileGetPath folder
for_ mbFolderPath \ folderPath -> do
exists <- doesDirectoryExist folderPath
when exists do
filePaths <- listDirectory folderPath
for_ filePaths \ filePath -> when ( takeExtension filePath == ".mb" ) do
mbDoc <- loadDocument uniqueSupply ( folderPath </> filePath )
case mbDoc of
Left errMessage -> warningDialog window filePath errMessage
Right doc -> do
let
newDocHist :: DocumentHistory
newDocHist = newHistory doc
newFileTab uiElts vars ( Just newDocHist ) tabLoc
updateHistoryState uiElts ( Just newDocHist )
--------------------
-- Save & Save as --
@ -342,9 +343,10 @@ withSavePath ( UIElements {..} ) action = do
GTK.nativeDialogShow fileChooser
void $ GTK.afterNativeDialogResponse fileChooser \ response -> do
when ( response == fromIntegral ( fromEnum GTK.ResponseTypeAccept ) ) do
saveFile <- GTK.fileChooserGetFile fileChooser
mbSavePath <- fmap fullFilePath <$> GIO.fileGetPath saveFile
for_ mbSavePath action
mbSaveFile <- GTK.fileChooserGetFile fileChooser
for_ mbSaveFile \ saveFile -> do
mbSavePath <- fmap fullFilePath <$> GIO.fileGetPath saveFile
for_ mbSavePath action
where
fullFilePath :: FilePath -> FilePath
fullFilePath fp

10
src/app/MetaBrush/Application.hs
View file

@ -75,10 +75,6 @@ import qualified Control.Concurrent.STM as STM
import qualified Control.Concurrent.STM.TVar as STM
( newTVarIO, readTVar, writeTVar )
-- text
import qualified Data.Text as Text
( pack )
-- transformers
import Control.Monad.Trans.Reader
( runReaderT )
@ -229,7 +225,7 @@ runApplication application = do
display <- GTK.rootGetDisplay window
dataPath <- Directory.canonicalizePath =<< Cabal.getDataDir
themePath <- Text.pack <$> ( Directory.canonicalizePath =<< Cabal.getDataFileName "theme.css" )
themePath <- ( Directory.canonicalizePath =<< Cabal.getDataFileName "theme.css" )
cssProvider <- GTK.cssProviderNew
GTK.cssProviderLoadFromPath cssProvider themePath
GTK.styleContextAddProviderForDisplay display cssProvider 1000
@ -268,8 +264,8 @@ runApplication application = do
mainView <- GTK.boxNew GTK.OrientationVertical 0
GTK.panedSetStartChild mainPane mainView
GTK.panedSetEndChild mainPane panelBox
GTK.panedSetStartChild mainPane ( Just mainView )
GTK.panedSetEndChild mainPane ( Just panelBox )
viewportGrid <- GTK.gridNew

4
src/app/MetaBrush/UI/Panels.hs
View file

@ -36,8 +36,8 @@ createPanelBar panelBox = do
GTK.notebookSetGroupName panels1 ( Just "Panel" )
GTK.notebookSetGroupName panels2 ( Just "Panel" )
GTK.panedSetStartChild pane1 panels1
GTK.panedSetEndChild pane1 panels2
GTK.panedSetStartChild pane1 ( Just panels1 )
GTK.panedSetEndChild pane1 ( Just panels2 )
strokesPanel <- GTK.boxNew GTK.OrientationVertical 0
brushesPanel <- GTK.boxNew GTK.OrientationVertical 0

2
src/splines/Math/Bezier/Cubic/Fit.hs
View file

@ -243,7 +243,7 @@ fitPiece dist_tol t_tol maxIters p tp qs r tr =
hermiteParameters ( Mat22 a11' a12' a21' a22' ) ( Vector2D b1' b2' ) ( i + 1 ) rest
hermiteParameters a b _ [] = pure ( linearSolve a b )
Vector2D s1 s2 <- hermiteParameters ( Mat22 0 0 0 0 ) ( Vector2D 0 0 ) 0 qs
~(Vector2D s1 s2) <- hermiteParameters ( Mat22 0 0 0 0 ) ( Vector2D 0 0 ) 0 qs
let
-- Convert from Hermite form to Bézier form.

26
src/splines/Math/Linear/Solve.hs
View file

@ -1,12 +1,18 @@
{-# LANGUAGE DataKinds #-}
module Math.Linear.Solve
( linearSolve )
where
-- hmatrix
import qualified Numeric.LinearAlgebra as LAPACK
( linearSolveSVD )
import qualified Numeric.LinearAlgebra.Data as HMatrix
( Matrix, col, matrix, atIndex )
-- base
import Data.Maybe
( fromJust )
-- eigen
import qualified Eigen.Matrix as Eigen
( Matrix, toList, fromList )
import qualified Eigen.Solver.LA as Eigen
( Decomposition(..), solve )
-- MetaBrush
import Math.Vector2D
@ -15,7 +21,11 @@ import Math.Vector2D
--------------------------------------------------------------------------------
linearSolve :: Mat22 Double -> Vector2D Double -> Vector2D Double
linearSolve ( Mat22 a b c d ) ( Vector2D p q ) = Vector2D ( sol `HMatrix.atIndex` (0,0) ) ( sol `HMatrix.atIndex` (1,0) )
linearSolve ( Mat22 a b c d ) ( Vector2D p q ) = Vector2D u v
where
sol :: HMatrix.Matrix Double
sol = LAPACK.linearSolveSVD ( HMatrix.matrix 2 [a,b,c,d] ) ( HMatrix.col [p,q] )
[[u],[v]] = Eigen.toList
$ Eigen.solve Eigen.JacobiSVD
( fromJust ( Eigen.fromList [[a,b],[c,d]] )
:: Eigen.Matrix 2 2 Double )
( fromJust ( Eigen.fromList [[p],[q]] )
:: Eigen.Matrix 2 1 Double )

26
src/splines/Math/Vector2D.hs
View file

@ -2,10 +2,15 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
module Math.Vector2D
( Point2D(..), Vector2D(.., Vector2D), Mat22(..)
@ -17,7 +22,7 @@ module Math.Vector2D
import Data.Monoid
( Sum(..) )
import GHC.Generics
( Generic, Generic1, Generically(..), Generically1(..) )
-- acts
import Data.Act
@ -29,7 +34,7 @@ import Control.DeepSeq
-- groups
import Data.Group
( Group )
( Group(..) )
-- groups-generic
import Data.Group.Generics
@ -73,3 +78,20 @@ data Segment p =
deriving Applicative
via Generically1 Segment
deriving anyclass ( NFData, NFData1 )
-- TODO: move the following to the groups or groups-generic package.
ginvert :: forall g. ( Generic g, Group ( Rep g () ) ) => g -> g
ginvert = to . invert @( Rep g () ) . from
gpow :: forall n g. ( Integral n, Generic g, Group ( Rep g () ) ) => g -> n -> g
gpow x n = to ( pow @( Rep g () ) ( from x ) n )
instance
( Generic g
, Monoid ( Generically g )
, Group ( Rep g () )
)
=> Group ( Generically g ) where
invert (Generically x) = Generically (ginvert x)
pow (Generically x) n = Generically (gpow x n)