diff --git a/MetaBrush.cabal b/MetaBrush.cabal index b61f01d..58db16a 100644 --- a/MetaBrush.cabal +++ b/MetaBrush.cabal @@ -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 diff --git a/app/Main.hs b/app/Main.hs index 9c77d7a..ad2335f 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} diff --git a/cabal.project b/cabal.project index c44af15..54091b1 100644 --- a/cabal.project +++ b/cabal.project @@ -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" diff --git a/shell.nix b/shell.nix new file mode 100644 index 0000000..c760631 --- /dev/null +++ b/shell.nix @@ -0,0 +1,30 @@ +let np = import {}; +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 + ''; +} \ No newline at end of file diff --git a/src/app/MetaBrush/Action.hs b/src/app/MetaBrush/Action.hs index 0302a5e..5c68a96 100644 --- a/src/app/MetaBrush/Action.hs +++ b/src/app/MetaBrush/Action.hs @@ -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 diff --git a/src/app/MetaBrush/Application.hs b/src/app/MetaBrush/Application.hs index 9e16e69..316c56b 100644 --- a/src/app/MetaBrush/Application.hs +++ b/src/app/MetaBrush/Application.hs @@ -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 diff --git a/src/app/MetaBrush/UI/Panels.hs b/src/app/MetaBrush/UI/Panels.hs index 1dea548..c791c3b 100644 --- a/src/app/MetaBrush/UI/Panels.hs +++ b/src/app/MetaBrush/UI/Panels.hs @@ -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 diff --git a/src/splines/Math/Bezier/Cubic/Fit.hs b/src/splines/Math/Bezier/Cubic/Fit.hs index 133997f..3ee2424 100644 --- a/src/splines/Math/Bezier/Cubic/Fit.hs +++ b/src/splines/Math/Bezier/Cubic/Fit.hs @@ -242,8 +242,8 @@ fitPiece dist_tol t_tol maxIters p tp qs r tr = b2' = b2 + ( q' ^.^ f1i ) 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. diff --git a/src/splines/Math/Linear/Solve.hs b/src/splines/Math/Linear/Solve.hs index f6f2034..d152ce3 100644 --- a/src/splines/Math/Linear/Solve.hs +++ b/src/splines/Math/Linear/Solve.hs @@ -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 ) diff --git a/src/splines/Math/Vector2D.hs b/src/splines/Math/Vector2D.hs index 5b7ddc6..75c78b8 100644 --- a/src/splines/Math/Vector2D.hs +++ b/src/splines/Math/Vector2D.hs @@ -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)