diff --git a/exec/Graphics.hs b/exec/Graphics.hs new file mode 100644 --- /dev/null +++ b/exec/Graphics.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE OverloadedStrings #-} + +import Diagrams.Backend.Cairo (Cairo) +import Diagrams.Prelude +import Typed.Spreadsheet + +data AColor = Red | Orange | Yellow | Green | Blue | Purple + deriving (Enum, Bounded, Show) + +toColor :: AColor -> Colour Double +toColor Red = red +toColor Orange = orange +toColor Yellow = yellow +toColor Green = green +toColor Blue = blue +toColor Purple = purple + +main :: IO () +main = graphicalUI "Example program" logic + where + logic = combine <$> radioButton "Color" Red [Orange .. Purple] + <*> spinButtonAt 100 "Radius" 1 + <*> spinButton "X Coordinate" 1 + <*> spinButton "Y Coordinate" 1 + + combine :: AColor -> Double -> Double -> Double -> Diagram Cairo + combine color r x y = + circle r # fc (toColor color) # translate (r2 (x, -y)) diff --git a/exec/Main.hs b/exec/Main.hs deleted file mode 100644 --- a/exec/Main.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -import Control.Applicative -import Typed.Spreadsheet - -main :: IO () -main = textUI "Example program" logic - where - logic = combine <$> checkBox "a" - <*> spinButton "b" 1 - <*> spinButton "c" 0.1 - <*> entry "d" - - combine a b c d = display (a, b + c, d) diff --git a/exec/Text.hs b/exec/Text.hs new file mode 100644 --- /dev/null +++ b/exec/Text.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE OverloadedStrings #-} + +import Control.Applicative +import Typed.Spreadsheet + +main :: IO () +main = textUI "Example program" logic + where + logic = combine <$> checkBox "a" + <*> spinButton "b" 1 + <*> spinButton "c" 0.1 + <*> entry "d" + + combine a b c d = display (a, b + c, d) diff --git a/src/Typed/Spreadsheet.hs b/src/Typed/Spreadsheet.hs --- a/src/Typed/Spreadsheet.hs +++ b/src/Typed/Spreadsheet.hs @@ -43,6 +43,42 @@ -- > d <- entry "d" -- > return (display (a, b + c, d)) ) -- +-- This library also supports graphical output, like in the following program: +-- +-- > {-# LANGUAGE OverloadedStrings #-} +-- > +-- > import Diagrams.Backend.Cairo (Cairo) +-- > import Diagrams.Prelude +-- > import Typed.Spreadsheet +-- > +-- > data AColor = Red | Orange | Yellow | Green | Blue | Purple +-- > deriving (Enum, Bounded, Show) +-- > +-- > toColor :: AColor -> Colour Double +-- > toColor Red = red +-- > toColor Orange = orange +-- > toColor Yellow = yellow +-- > toColor Green = green +-- > toColor Blue = blue +-- > toColor Purple = purple +-- > +-- > main :: IO () +-- > main = graphicalUI "Example program" logic +-- > where +-- > logic = combine <$> radioButton "Color" Red [Orange .. Purple] +-- > <*> spinButtonAt 100 "Radius" 1 +-- > <*> spinButton "X Coordinate" 1 +-- > <*> spinButton "Y Coordinate" 1 +-- > +-- > combine :: AColor -> Double -> Double -> Double -> Diagram Cairo +-- > combine color r x y = +-- > circle r # fc (toColor color) # translate (r2 (x, -y)) +-- +-- This produces a canvas that colors, resizes, and moves a circle in response +-- to user input: +-- +-- <> +-- -- The general workflow for this library is: -- -- * You build primitive `Updatable` values using `checkBox`, `spinButton`, @@ -72,6 +108,7 @@ -- * Types Updatable , textUI + , graphicalUI -- * Controls , checkBox @@ -79,6 +116,11 @@ , entry , radioButton + -- * Controls with Defaults + , checkBoxAt + , spinButtonAt + , entryAt + -- * Utilities , display @@ -87,12 +129,16 @@ ) where import Control.Applicative +import Control.Concurrent (threadDelay) import Control.Concurrent.STM (STM) import Control.Foldl (Fold(..)) import Control.Monad.IO.Class (liftIO) import Data.Monoid import Data.String (IsString(..)) import Data.Text (Text) +import Diagrams.Backend.Cairo (Cairo) +import Diagrams.Backend.Gtk (renderToGtk) +import Diagrams.Prelude (Diagram, r2, translate, (#)) import Lens.Micro (_Left, _Right) import Graphics.UI.Gtk (AttrOp((:=))) @@ -179,10 +225,10 @@ -- | Use a `Control` to obtain updatable input `Updatable`s data Control = Control - { _checkBox :: Text -> Cell Bool - , _spinButton :: Text -> Double -> Cell Double - , _entry :: Text -> Cell Text - , _radioButton :: forall a . Show a => Text -> a -> [a] -> Cell a + { _checkBoxAt :: Bool -> Text -> Cell Bool + , _spinButtonAt :: Double -> Text -> Double -> Cell Double + , _entryAt :: Text -> Text -> Cell Text + , _radioButton :: forall a . Show a => Text -> a -> [a] -> Cell a } -- | Build a `Text`-based user interface @@ -192,7 +238,61 @@ -> Updatable Text -- ^ Program logic -> IO () -textUI title (Updatable k) = do +textUI = ui textSetup processTextEvent + where + textSetup :: Gtk.HBox -> IO Gtk.TextBuffer + textSetup hBox = do + textView <- Gtk.textViewNew + textBuffer <- Gtk.get textView Gtk.textViewBuffer + Gtk.set textView + [ Gtk.textViewEditable := False + , Gtk.textViewCursorVisible := False + ] + + hAdjust <- Gtk.textViewGetHadjustment textView + vAdjust <- Gtk.textViewGetVadjustment textView + scrolledWindow <- Gtk.scrolledWindowNew (Just hAdjust) (Just vAdjust) + Gtk.set scrolledWindow + [ Gtk.containerChild := textView + , Gtk.scrolledWindowShadowType := Gtk.ShadowIn + ] + Gtk.boxPackStart hBox scrolledWindow Gtk.PackGrow 0 + return textBuffer + + processTextEvent :: Gtk.TextBuffer -> Text -> IO () + processTextEvent textBuffer txt = + Gtk.set textBuffer [ Gtk.textBufferText := txt ] + +-- | Build a `Diagram`-based user interface +graphicalUI + :: Text + -- ^ Window title + -> Updatable (Diagram Cairo) + -- ^ Program logic + -> IO () +graphicalUI = ui setupGraphical processGraphicalEvent + where + setupGraphical :: Gtk.HBox -> IO Gtk.DrawingArea + setupGraphical hBox = do + drawingArea <- Gtk.drawingAreaNew + Gtk.boxPackStart hBox drawingArea Gtk.PackGrow 0 + return drawingArea + + processGraphicalEvent :: Gtk.DrawingArea -> Diagram Cairo -> IO () + processGraphicalEvent drawingArea diagram = do + drawWindow <- Gtk.widgetGetDrawWindow drawingArea + (w, h) <- Gtk.widgetGetSize drawingArea + let w' = fromIntegral w / 2 + let h' = fromIntegral h / 2 + renderToGtk drawWindow (diagram # translate (r2 (w', h'))) + +-- | Shared logic for `textUI` and `graphicalUI` +ui :: (Gtk.HBox -> IO a) + -> (a -> b -> IO ()) + -> Text + -> Updatable b + -> IO () +ui setup process title (Updatable k) = do _ <- Gtk.initGUI window <- Gtk.windowNew @@ -200,26 +300,11 @@ [ Gtk.containerBorderWidth := 5 ] - textView <- Gtk.textViewNew - textBuffer <- Gtk.get textView Gtk.textViewBuffer - Gtk.set textView - [ Gtk.textViewEditable := False - , Gtk.textViewCursorVisible := False - ] - - hAdjust <- Gtk.textViewGetHadjustment textView - vAdjust <- Gtk.textViewGetVadjustment textView - scrolledWindow <- Gtk.scrolledWindowNew (Just hAdjust) (Just vAdjust) - Gtk.set scrolledWindow - [ Gtk.containerChild := textView - , Gtk.scrolledWindowShadowType := Gtk.ShadowIn - ] - vBox <- Gtk.vBoxNew False 5 hBox <- Gtk.hBoxNew False 5 - Gtk.boxPackStart hBox vBox Gtk.PackNatural 0 - Gtk.boxPackStart hBox scrolledWindow Gtk.PackGrow 0 + Gtk.boxPackStart hBox vBox Gtk.PackNatural 0 + a <- setup hBox Gtk.set window [ Gtk.windowTitle := title @@ -228,14 +313,14 @@ , Gtk.windowDefaultHeight := 400 ] - let __spinButton :: Text -> Double -> Cell Double - __spinButton label stepX = Cell (do + let __spinButtonAt :: Double -> Text -> Double -> Cell Double + __spinButtonAt s0 label stepX = Cell (do tmvar <- STM.newEmptyTMVarIO let minX = fromIntegral (minBound :: Int) let maxX = fromIntegral (maxBound :: Int) spinButton_ <- Gtk.spinButtonNewWithRange minX maxX stepX Gtk.set spinButton_ - [ Gtk.spinButtonValue := 0 + [ Gtk.spinButtonValue := s0 ] _ <- Gtk.onValueSpinned spinButton_ (do n <- Gtk.get spinButton_ Gtk.spinButtonValue @@ -249,12 +334,13 @@ Gtk.boxPackStart vBox frame Gtk.PackNatural 0 Gtk.widgetShowAll vBox - return (STM.takeTMVar tmvar, Fold.lastDef 0) ) + return (STM.takeTMVar tmvar, Fold.lastDef s0) ) - let __checkBox :: Text -> Cell Bool - __checkBox label = Cell (do + let __checkBoxAt :: Bool -> Text -> Cell Bool + __checkBoxAt s0 label = Cell (do checkButton <- Gtk.checkButtonNewWithLabel label + Gtk.set checkButton [ Gtk.toggleButtonActive := s0 ] tmvar <- STM.newEmptyTMVarIO _ <- Gtk.on checkButton Gtk.toggled (do pressed <- Gtk.get checkButton Gtk.toggleButtonActive @@ -262,10 +348,10 @@ Gtk.boxPackStart vBox checkButton Gtk.PackNatural 0 Gtk.widgetShowAll vBox - return (STM.takeTMVar tmvar, Fold.lastDef False) ) + return (STM.takeTMVar tmvar, Fold.lastDef s0) ) - let __entry :: Text -> Cell Text - __entry label = Cell (do + let __entryAt :: Text -> Text -> Cell Text + __entryAt s0 label = Cell (do entry_ <- Gtk.entryNew frame <- Gtk.frameNew @@ -273,6 +359,7 @@ [ Gtk.containerChild := entry_ , Gtk.frameLabel := label ] + Gtk.set entry_ [ Gtk.entryText := s0 ] tmvar <- STM.newEmptyTMVarIO _ <- Gtk.on entry_ Gtk.editableChanged (do @@ -281,7 +368,7 @@ Gtk.boxPackStart vBox frame Gtk.PackNatural 0 Gtk.widgetShowAll frame - return (STM.takeTMVar tmvar, Fold.lastDef Text.empty) ) + return (STM.takeTMVar tmvar, Fold.lastDef s0) ) let __radioButton :: Show a => Text -> a -> [a] -> Cell a __radioButton label x xs = Cell (do @@ -293,8 +380,8 @@ button <- f (show a) Gtk.boxPackStart vBoxRadio button Gtk.PackNatural 0 _ <- Gtk.on button Gtk.toggled (do - mode <- Gtk.get button Gtk.toggleButtonMode - if mode + active <- Gtk.get button Gtk.toggleButtonActive + if active then STM.atomically (STM.putTMVar tmvar a) else return () ) return button @@ -312,21 +399,21 @@ return (STM.takeTMVar tmvar, Fold.lastDef x) ) let control = Control - { _checkBox = __checkBox - , _spinButton = __spinButton - , _entry = __entry - , _radioButton = __radioButton + { _checkBoxAt = __checkBoxAt + , _spinButtonAt = __spinButtonAt + , _entryAt = __entryAt + , _radioButton = __radioButton } doneTMVar <- STM.newEmptyTMVarIO - let run :: Cell Text -> IO () - run (Cell m) = do + let run (Cell m) = do (stm, Fold step begin done) <- Gtk.postGUISync m + -- I don't know why this delay is necessary for diagrams output + threadDelay 200000 let loop x = do - let txt = done x - Gtk.postGUISync - (Gtk.set textBuffer [ Gtk.textBufferText := txt ]) + let b = done x + Gtk.postGUISync (process a b) let doneTransaction = do STM.takeTMVar doneTMVar return Nothing @@ -350,7 +437,7 @@ :: Text -- ^ Label -> Updatable Bool -checkBox label = Updatable (\control -> _checkBox control label) +checkBox = checkBoxAt False -- | A `Double` spin button spinButton @@ -359,14 +446,14 @@ -> Double -- ^ Step size -> Updatable Double -spinButton label x = Updatable (\control -> _spinButton control label x) +spinButton = spinButtonAt 0 -- | A `Text` entry entry :: Text -- ^ Label -> Updatable Text -entry label = Updatable (\control -> _entry control label) +entry = entryAt Text.empty -- | A control that selects from one or more mutually exclusive choices radioButton @@ -381,6 +468,37 @@ radioButton label a0 as = Updatable (\control -> _radioButton control label a0 as) +-- | Same as `checkBox` except that you can specify the initial state +checkBoxAt + :: Bool + -- ^ Initial state + -> Text + -- ^ Label + -> Updatable Bool +checkBoxAt s0 label = + Updatable (\control -> _checkBoxAt control s0 label) + +-- | Same as `spinButton` except that you can specify the initial state +spinButtonAt + :: Double + -- ^ Initial state + -> Text + -- ^ Label + -> Double + -- ^ Step size + -> Updatable Double +spinButtonAt s0 label x = + Updatable (\control -> _spinButtonAt control s0 label x) + +-- | Same as `entry` except that you can specify the initial state +entryAt + :: Text + -- ^ Initial state + -> Text + -- ^ Label + -> Updatable Text +entryAt s0 label = Updatable (\control -> _entryAt control s0 label) + -- | Convert a `Show`able value to `Text` display :: Show a => a -> Text display = Text.pack . show @@ -441,3 +559,58 @@ -- Example input and output: -- -- <> +-- +-- Sinusoid plot: +-- +-- > {-# LANGUAGE OverloadedStrings #-} +-- > +-- > import Diagrams.Backend.Cairo (Cairo) +-- > import Diagrams.Prelude +-- > import Typed.Spreadsheet +-- > +-- > main :: IO () +-- > main = graphicalUI "Example program" logic +-- > where +-- > logic = combine <$> spinButtonAt 50 "Amplitude (Pixels)" 0.1 +-- > <*> spinButtonAt 0.1 "Frequency (Pixels⁻¹)" 0.001 +-- > <*> spinButtonAt 90 "Phase (Degrees)" 1 +-- > +-- > combine :: Double -> Double -> Double -> Diagram Cairo +-- > combine amplitude frequency phase = strokeP (fromVertices points) <> axes +-- > where +-- > axes = arrowBetween (p2 (0, 0)) (p2 ( 100, 0)) +-- > <> arrowBetween (p2 (0, 0)) (p2 (-100, 0)) +-- > <> arrowBetween (p2 (0, 0)) (p2 ( 0, 100)) +-- > <> arrowBetween (p2 (0, 0)) (p2 ( 0, -100)) +-- > +-- > f x = - amplitude * cos (frequency * x + phase * pi / 180) +-- > +-- > points = map (\x -> p2 (x, f x)) [-100, -99 .. 100] +-- +-- Example input and output: +-- +-- <> +-- +-- Factor diagram: +-- +-- > {-# LANGUAGE OverloadedStrings #-} +-- > +-- > import Diagrams.Backend.Cairo (Cairo) +-- > import Diagrams.Prelude +-- > import Diagrams.TwoD.Factorization (factorDiagram') +-- > import Typed.Spreadsheet +-- > +-- > main :: IO () +-- > main = graphicalUI "Factor diagram" logic +-- > where +-- > logic = combine <$> spinButtonAt 3 "Factor #1" 1 +-- > <*> spinButtonAt 3 "Factor #2" 1 +-- > <*> spinButtonAt 3 "Factor #3" 1 +-- > +-- > combine :: Double -> Double -> Double -> Diagram Cairo +-- > combine x y z = +-- > factorDiagram' [truncate x, truncate y, truncate z] # scale 10 +-- +-- Example input and output: +-- +-- <> diff --git a/typed-spreadsheet.cabal b/typed-spreadsheet.cabal --- a/typed-spreadsheet.cabal +++ b/typed-spreadsheet.cabal @@ -1,5 +1,5 @@ Name: typed-spreadsheet -Version: 1.0.0 +Version: 1.0.1 Cabal-Version: >=1.8.0.2 Build-Type: Simple License: BSD3 @@ -31,22 +31,35 @@ Library Hs-Source-Dirs: src Build-Depends: - base >= 4 && < 5 , - async >= 2.0 && < 2.1 , - foldl >= 1.1 && < 1.2 , - gtk3 >= 0.14.0 && < 0.15, - microlens < 0.4 , - stm < 2.5 , - text < 1.3 , - transformers >= 0.2.0.0 && < 0.5 + base >= 4 && < 5 , + async >= 2.0 && < 2.1 , + diagrams-cairo >= 1.3 && < 1.4 , + diagrams-gtk >= 1.3 && < 1.4 , + diagrams-lib >= 1.3 && < 1.4 , + foldl >= 1.1 && < 1.2 , + gtk >= 0.13 && < 0.14, + microlens < 0.4 , + stm < 2.5 , + text < 1.3 , + transformers >= 0.2.0.0 && < 0.5 Exposed-Modules: Typed.Spreadsheet GHC-Options: -O2 -Wall Executable typed-spreadsheet-example Hs-Source-Dirs: exec - Main-Is: Main.hs + Main-Is: Text.hs Build-Depends: - base >= 4 && < 5 , - typed-spreadsheet , - text < 1.3 + base >= 4 && < 5 , + text < 1.3, + typed-spreadsheet + GHC-Options: -O2 -Wall -threaded + +Executable typed-spreadsheet-example-graphics + Hs-Source-Dirs: exec + Main-Is: Graphics.hs + Build-Depends: + base >= 4 && < 5 , + diagrams-cairo >= 1.3 && < 1.4, + diagrams-lib >= 1.3 && < 1.4, + typed-spreadsheet GHC-Options: -O2 -Wall -threaded