diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Aditya Siram (c) 2018 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Aditya Siram nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.org b/README.org new file mode 100644 --- /dev/null +++ b/README.org @@ -0,0 +1,15 @@ +#+TITLE: README + +* fltkhs-themes +`fltkhs-themes` tries to make it easy to write nice consistent-looking +[FLTKHS](http://hackage.haskell.org/package/fltkhs-0.5.4.5/docs/Graphics-UI-FLTK-LowLevel-FLTKHS.html) +applications by providing drop-in light themed replacement widgets to the +standard ones with minimal performance and memory overhead. + +Please see the [Hackage +docs](https://hackage.haskell.org/package/fltkhs-themes/docs/Graphics-UI-FLTK-Theme-Light.html) for much more information on installation and getting started with this package. + +* Screenshots +There is a small but growing [showcase +app](https://github.com/deech/fltkhs-themes-demo) with screenshots that gives a +better idea of look-and-feel. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/doc/images/cancel-button-example.png b/doc/images/cancel-button-example.png new file mode 100644 Binary files /dev/null and b/doc/images/cancel-button-example.png differ diff --git a/doc/images/forward-image-example.png b/doc/images/forward-image-example.png new file mode 100644 Binary files /dev/null and b/doc/images/forward-image-example.png differ diff --git a/doc/images/left-image-example.png b/doc/images/left-image-example.png new file mode 100644 Binary files /dev/null and b/doc/images/left-image-example.png differ diff --git a/doc/images/ok-button-example.png b/doc/images/ok-button-example.png new file mode 100644 Binary files /dev/null and b/doc/images/ok-button-example.png differ diff --git a/doc/images/return-image-example.png b/doc/images/return-image-example.png new file mode 100644 Binary files /dev/null and b/doc/images/return-image-example.png differ diff --git a/doc/images/rewind-image-example.png b/doc/images/rewind-image-example.png new file mode 100644 Binary files /dev/null and b/doc/images/rewind-image-example.png differ diff --git a/doc/images/right-image-example.png b/doc/images/right-image-example.png new file mode 100644 Binary files /dev/null and b/doc/images/right-image-example.png differ diff --git a/doc/images/small-up-down-arrow-example.png b/doc/images/small-up-down-arrow-example.png new file mode 100644 Binary files /dev/null and b/doc/images/small-up-down-arrow-example.png differ diff --git a/fltkhs-themes.cabal b/fltkhs-themes.cabal new file mode 100644 --- /dev/null +++ b/fltkhs-themes.cabal @@ -0,0 +1,102 @@ +-- This file has been generated from package.yaml by hpack version 0.28.2. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: f817c1c2536810ecf9a6191153cc35ce69408e6bc81c4fa6f7c60e94b4ca672d + +name: fltkhs-themes +version: 0.1.0.0 +description: Please see the README on Github at +homepage: https://github.com/deech/fltkhs-themes#readme +bug-reports: https://github.com/deech/fltkhs-themes/issues +author: Aditya Siram +maintainer: aditya.siram@gmail.com +copyright: 2018 Aditya Siram +license: BSD3 +license-file: LICENSE +build-type: Custom +cabal-version: >= 1.24 +extra-source-files: + README.org +extra-doc-files: + doc/images/cancel-button-example.png + doc/images/forward-image-example.png + doc/images/left-image-example.png + doc/images/ok-button-example.png + doc/images/return-image-example.png + doc/images/rewind-image-example.png + doc/images/right-image-example.png + doc/images/small-up-down-arrow-example.png +data-files: + fonts/DejaVuSans.ttf + fonts/fineliner_script-webfont.ttf + fonts/Fineliner_Script.ttf + fonts/fontawesome-webfont.ttf + fonts/iosevka-ss08-regular.ttf + fonts/JosefinSlab-SemiBold.ttf + fonts/tobec___-webfont.ttf + fonts/YanoneKaffeesatz-Regular.ttf + images/brightness-field.png + images/dialog-apply.png + images/dialog-cancel.png + images/dialog-ok.png + images/down-small.png + images/forward.png + images/left.png + images/rewind.png + images/right.png + images/up-small.png + +source-repository head + type: git + location: https://github.com/deech/fltkhs-themes + +custom-setup + setup-depends: + Cabal >=2.2.0.0 && <3 + , base >=4.4 + +library + exposed-modules: + Graphics.UI.FLTK.Theme.Light + Graphics.UI.FLTK.Theme.Light.Assets + Graphics.UI.FLTK.Theme.Light.Browser + Graphics.UI.FLTK.Theme.Light.Button + Graphics.UI.FLTK.Theme.Light.Clock + Graphics.UI.FLTK.Theme.Light.ColorChooser + Graphics.UI.FLTK.Theme.Light.Common + Graphics.UI.FLTK.Theme.Light.Counter + Graphics.UI.FLTK.Theme.Light.Dial + Graphics.UI.FLTK.Theme.Light.Group + Graphics.UI.FLTK.Theme.Light.Input + Graphics.UI.FLTK.Theme.Light.Menu + Graphics.UI.FLTK.Theme.Light.Misc + Graphics.UI.FLTK.Theme.Light.Positioner + Graphics.UI.FLTK.Theme.Light.Progress + Graphics.UI.FLTK.Theme.Light.SimpleTerminal + Graphics.UI.FLTK.Theme.Light.Slider + Graphics.UI.FLTK.Theme.Light.Spinner + Graphics.UI.FLTK.Theme.Light.Table + Graphics.UI.FLTK.Theme.Light.Tabs + Graphics.UI.FLTK.Theme.Light.TextDisplay + Graphics.UI.FLTK.Theme.Light.TextEditor + Graphics.UI.FLTK.Theme.Light.Tree + Graphics.UI.FLTK.Theme.Light.Valuator + Graphics.UI.FLTK.Theme.Light.Window + Graphics.UI.FLTK.Theme.Light.Wizard + other-modules: + Paths_fltkhs_themes + hs-source-dirs: + src + ghc-options: -Wall -fno-warn-name-shadowing + build-depends: + base >=4.7 && <5 + , bytestring + , fltkhs >=0.6.0.0 + , load-font >=0.1.0.2 + , text >=1.2.2.0 + , vector >=0.12.0.1 + if os(linux) + extra-libraries: + fontconfig + default-language: Haskell2010 diff --git a/fonts/DejaVuSans.ttf b/fonts/DejaVuSans.ttf new file mode 100644 Binary files /dev/null and b/fonts/DejaVuSans.ttf differ diff --git a/fonts/Fineliner_Script.ttf b/fonts/Fineliner_Script.ttf new file mode 100644 Binary files /dev/null and b/fonts/Fineliner_Script.ttf differ diff --git a/fonts/JosefinSlab-SemiBold.ttf b/fonts/JosefinSlab-SemiBold.ttf new file mode 100644 Binary files /dev/null and b/fonts/JosefinSlab-SemiBold.ttf differ diff --git a/fonts/YanoneKaffeesatz-Regular.ttf b/fonts/YanoneKaffeesatz-Regular.ttf new file mode 100644 Binary files /dev/null and b/fonts/YanoneKaffeesatz-Regular.ttf differ diff --git a/fonts/fineliner_script-webfont.ttf b/fonts/fineliner_script-webfont.ttf new file mode 100644 Binary files /dev/null and b/fonts/fineliner_script-webfont.ttf differ diff --git a/fonts/fontawesome-webfont.ttf b/fonts/fontawesome-webfont.ttf new file mode 100644 Binary files /dev/null and b/fonts/fontawesome-webfont.ttf differ diff --git a/fonts/iosevka-ss08-regular.ttf b/fonts/iosevka-ss08-regular.ttf new file mode 100644 Binary files /dev/null and b/fonts/iosevka-ss08-regular.ttf differ diff --git a/fonts/tobec___-webfont.ttf b/fonts/tobec___-webfont.ttf new file mode 100644 Binary files /dev/null and b/fonts/tobec___-webfont.ttf differ diff --git a/images/brightness-field.png b/images/brightness-field.png new file mode 100644 Binary files /dev/null and b/images/brightness-field.png differ diff --git a/images/dialog-apply.png b/images/dialog-apply.png new file mode 100644 Binary files /dev/null and b/images/dialog-apply.png differ diff --git a/images/dialog-cancel.png b/images/dialog-cancel.png new file mode 100644 Binary files /dev/null and b/images/dialog-cancel.png differ diff --git a/images/dialog-ok.png b/images/dialog-ok.png new file mode 100644 Binary files /dev/null and b/images/dialog-ok.png differ diff --git a/images/down-small.png b/images/down-small.png new file mode 100644 Binary files /dev/null and b/images/down-small.png differ diff --git a/images/forward.png b/images/forward.png new file mode 100644 Binary files /dev/null and b/images/forward.png differ diff --git a/images/left.png b/images/left.png new file mode 100644 Binary files /dev/null and b/images/left.png differ diff --git a/images/rewind.png b/images/rewind.png new file mode 100644 Binary files /dev/null and b/images/rewind.png differ diff --git a/images/right.png b/images/right.png new file mode 100644 Binary files /dev/null and b/images/right.png differ diff --git a/images/up-small.png b/images/up-small.png new file mode 100644 Binary files /dev/null and b/images/up-small.png differ diff --git a/src/Graphics/UI/FLTK/Theme/Light.hs b/src/Graphics/UI/FLTK/Theme/Light.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/FLTK/Theme/Light.hs @@ -0,0 +1,285 @@ +{-| +Module: Graphics.UI.FLTK.Theme.Light + +A `Light` theme for [FLTKHS](http://hackage.haskell.org/package/fltkhs/docs/Graphics-UI-FLTK-LowLevel-FLTKHS.html). +-} +module Graphics.UI.FLTK.Theme.Light + ( + -- * Motivation + -- + -- $Motivation + + -- * Inspiration + -- + -- $Inspiration + + -- * Installation #Installation# + -- + -- $Installation + + -- * Getting Started #GettingStarted# + -- + -- $GettingStarted + + -- * Running In the REPL + -- + -- $RunningInTheREPL + + -- * Deployment #Deployment# + -- + -- $Deployment + + -- * Demo #Demo# + -- + -- $Demo + + -- * What's Missing + -- + -- $WhatsMissing + + -- * Assets + -- + -- $ThemeAssets + module Graphics.UI.FLTK.Theme.Light.Assets, + + -- * Banners + -- + -- | Some banners + module Graphics.UI.FLTK.Theme.Light.Misc, + + -- * Themed Widgets + module Graphics.UI.FLTK.Theme.Light.Browser, + module Graphics.UI.FLTK.Theme.Light.Button, + module Graphics.UI.FLTK.Theme.Light.Clock, + module Graphics.UI.FLTK.Theme.Light.ColorChooser, + module Graphics.UI.FLTK.Theme.Light.Common, + module Graphics.UI.FLTK.Theme.Light.Counter, + module Graphics.UI.FLTK.Theme.Light.Dial, + module Graphics.UI.FLTK.Theme.Light.Group, + module Graphics.UI.FLTK.Theme.Light.Input, + module Graphics.UI.FLTK.Theme.Light.Menu, + module Graphics.UI.FLTK.Theme.Light.Positioner, + module Graphics.UI.FLTK.Theme.Light.Progress, + module Graphics.UI.FLTK.Theme.Light.Slider, + module Graphics.UI.FLTK.Theme.Light.Spinner, + module Graphics.UI.FLTK.Theme.Light.Tabs, + module Graphics.UI.FLTK.Theme.Light.Table, + module Graphics.UI.FLTK.Theme.Light.TextDisplay, + module Graphics.UI.FLTK.Theme.Light.TextEditor, + module Graphics.UI.FLTK.Theme.Light.Tree, + module Graphics.UI.FLTK.Theme.Light.Valuator, + module Graphics.UI.FLTK.Theme.Light.Window, + module Graphics.UI.FLTK.Theme.Light.Wizard, + -- * Haddock barf + -- + -- $HaddockBarf + module Graphics.UI.FLTK.LowLevel.FLTKHS + ) +where +import Graphics.UI.FLTK.LowLevel.FLTKHS hiding + ( + adjusterNew + , browserNew + , buttonNew + , checkButtonNew + , choiceNew + , clockNew + , colorChooserNew + , counterNew + , dialNew + , doubleWindowNew + , fileInputNew + , fileBrowserNew + , fillDialNew + , fillSliderNew + , flcColorChooser + , groupNew + , horFillSliderNew + , horNiceSliderNew + , horSliderNew + , horValueSliderNew + , inputNew + , lightButtonNew + , lineDialNew + , menuButtonNew + , outputNew + , positionerNew + , progressNew + , returnButtonNew + , roundButtonNew + , selectBrowserNew + , scrolledNew + , singleWindowNew + , sliderNew + , spinnerNew + , sysMenuBarNew + , tabsNew + , tableCustom + , tableRowNew + , textDisplayNew + , textEditorNew + , toggleButtonNew + , treeNew + , valueInputNew + , valueOutputNew + , valueSliderNew + , windowNew + , wizardNew + ) +import Graphics.UI.FLTK.Theme.Light.Assets +import Graphics.UI.FLTK.Theme.Light.Browser +import Graphics.UI.FLTK.Theme.Light.Button +import Graphics.UI.FLTK.Theme.Light.Clock +import Graphics.UI.FLTK.Theme.Light.ColorChooser +import Graphics.UI.FLTK.Theme.Light.Common +import Graphics.UI.FLTK.Theme.Light.Counter +import Graphics.UI.FLTK.Theme.Light.Dial +import Graphics.UI.FLTK.Theme.Light.Group +import Graphics.UI.FLTK.Theme.Light.Input +import Graphics.UI.FLTK.Theme.Light.Menu +import Graphics.UI.FLTK.Theme.Light.Misc +import Graphics.UI.FLTK.Theme.Light.Positioner +import Graphics.UI.FLTK.Theme.Light.Progress +import Graphics.UI.FLTK.Theme.Light.Slider +import Graphics.UI.FLTK.Theme.Light.Spinner +import Graphics.UI.FLTK.Theme.Light.Tabs +import Graphics.UI.FLTK.Theme.Light.Table +import Graphics.UI.FLTK.Theme.Light.TextDisplay +import Graphics.UI.FLTK.Theme.Light.TextEditor +import Graphics.UI.FLTK.Theme.Light.Tree +import Graphics.UI.FLTK.Theme.Light.Valuator +import Graphics.UI.FLTK.Theme.Light.Window +import Graphics.UI.FLTK.Theme.Light.Wizard + +-- $Motivation +-- This package tries to make it easy to write nice consistent-looking +-- [FLTKHS](http://hackage.haskell.org/package/fltkhs-0.5.4.5/docs/Graphics-UI-FLTK-LowLevel-FLTKHS.html) +-- applications by providing drop-in light themed replacement widgets to the +-- standard ones with minimal performance and memory overhead. While +-- [FLTK](http://fltk.org) itself has very good performance and memory usage the +-- default look of the widgets is quite dated; this package aims to bridge that +-- gap by providing a more modern interface while retaining the responsiveness. +-- +-- NOTE: This is not a theme in the same sense as CSS; the look is achieved +-- simply providing a custom drawing routine for each widget. + +-- $Inspiration +-- The Light theme is massively indebted to and steals shamelessly from the +-- excellent [Qooxdoo](http://qooxdoo.org) project which manages to create a +-- [very slick](http://www.qooxdoo.org/current/widgetbrowser/) interface which +-- is at the same time production-grade /and/ easy to understand and use. + +-- $GettingStarted +-- The underlying widget API has not been touched so all of the existing +-- [FLTK](http://www.fltk.org/doc-1.4/index.html) and +-- [FLTKHS](http://hackage.haskell.org/package/fltkhs-0.5.4.5/docs/Graphics-UI-FLTK-LowLevel-FLTKHS.html) +-- documentation still applies which makes switching over from an existing +-- codebase, not entirely but mostly, frictionless. +-- +-- The simplest app skeleton to get started with this theme is as follows: +-- +-- @ +-- {-\# LANGUAGE ImplicitParams \#-} -- (1) +-- module Main where +-- ... +-- import Graphics.UI.FLTK.Theme.Light -- (2) +-- ... +-- main :: IO () +-- main = do +-- assets <- configureTheme -- (3) +-- let ?assets = assets -- (3) +-- ui +-- FL.run +-- FL.flush +-- +-- ui :: (?assets :: Assets) => IO () -- (4) +-- ui = ... +-- @ +-- +-- It involves only (1) enabling the /ImplicitParams/ extension, (2) importing +-- this module (3) doing some minor setup before the actual app code and (4) +-- threading the implicit constraint to whatever function uses this theme. +-- "Graphics.UI.FLTK.Theme.Light.Assets#AssetsDescriptionAndUsage" has more information. +-- +-- The /ImplicitParams/ requirement is so that widgets have access to the +-- resources needed by this theme (icons, images, fonts etc.). See +-- "Graphics.UI.FLTK.Theme.Light.Assets#WhyImplicitParams" for more information. + +-- $WhatsMissing +-- While most of the widgets and functionality in +-- [FLTKHS](hackage.haskell.org/package/fltkhs/docs/Graphics-UI-FLTK-LowLevel-FLTKHS.html#g:21) +-- have and themed analogs but some do not mostly because, in my view, they don't fit into app +-- development much nowadays and so weren't worth porting. If there's a +-- pressing need let me know. +-- +-- * Fill and "Nice" Sliders - here they fallback to the slider provided by the theme. +-- * [FLTK's Pre-Made Modal Dialogs](https://hackage.haskell.org/package/fltkhs/docs/Graphics-UI-FLTK-LowLevel-Ask.html) +-- * [FLTK's Square Clock](https://hackage.haskell.org/package/fltkhs/docs/Graphics-UI-FLTK-LowLevel-Clock.html) +-- * Fluid integration - FLTK ships with [FLUID](https://en.wikipedia.org/wiki/FLUID) GUI builder and the default FLTKHS integrates ("Graphics.UI.FLTK.LowLevel.FLTKHS#FluidSupport") with it quite well but currently there is no support for using it +-- to create themed apps. This is definitely on the roadmap and should be resolved in the near future. + +-- $HaddockBarf +-- There is no reason to read anything below, this module hides the default +-- widgets it overrides and then re-exports what it doesn't. The re-exported +-- module from +-- [FLTKHS](http://hackage.haskell.org/package/fltkhs-0.5.4.5/docs/Graphics-UI-FLTK-LowLevel-FLTKHS.html) +-- in turn re-exports modules from that package. Instead of just showing the +-- exported module as a link Haddock insists on flattening and barfing out all +-- of its contents here. Sorry, didn't know how to get around it. +-- + +-- $ThemeAssets +-- The resources bundled with the theme, see the module documentation for more information. + +-- $Installation +-- Installation follows the same basic procedure as +-- "Graphics.UI.FLTK.LowLevel.FLTKHS#Installation". The only difference is that +-- those instructions use the default [hello world +-- skeleton](https://github.com/deech/fltkhs-hello-world) whereas for themed UIs +-- you'll want the [themed +-- skeleton](https://github.com/deech/fltkhs-light-theme-skeleton), so wherever +-- the original instructions tell you to use the default skeleton use the latter +-- instead. And to run it, instead of: +-- +-- @ +-- > stack exec fltkhs-hello-world +-- @ +-- +-- do +-- +-- @ +-- > stack exec fltkhs-light-theme-skeleton +-- @ +-- + +-- $Deployment +-- This package bundles a lot of local assets, images and especially fonts so +-- deploying a themed application is not as simple as just adding an executable +-- file to your path. To help with this the [skeleton +-- project](https://github.com/deech/fltkhs-light-theme-skeleton) uses the +-- [asset-bundle](http://hackage.haskell.org/package/asset-bundle) package to +-- create a ZIP archive of all the assets the application needs at runtime. The +-- [package +-- docs](http://hackage.haskell.org/package/asset-bundle/docs/Distribution-Simple-AssetBundle.html) +-- have a lot more info but in a nutshell when you build the skeletop app a ZIP +-- archive, @fltkhs-light-theme-skeleton_bundled.zip@, is generated for you +-- and placed deep inside your @.stack-work@ (or @dist-new@ if you're using +-- Cabal) directory. It contains all the assets and a runner script (@run.sh@ on +-- Linux and OSX and @run.bat@ on Windows) which invokes the executable, passes +-- along all command line arguments and sets up the environment so it +-- can find the assets at runtime. + +-- $Demo +-- In addition to the [skeleton +-- project](https://github.com/deech/fltkhs-light-theme-skeleton) there is a +-- also a small but steadily growing [showcase +-- app](https://github.com/deech/fltkhs-themes-demo) that gives a better idea of +-- the look-and-feel of this theme. More will be added as time permits. + +-- $RunningInTheREPL +-- Assuming you're using the [skeleton project](https://github.com/deech/fltkhs-light-theme-skeleton) getting a GUI running in +-- GHCi is pretty much the same "Graphics.UI.FLTK.LowLevel.FLTKHS#RunningInTheREPL" except the command to run the REPL is: +-- +-- @ +-- stack ghci --flag fltkhs:bundled fltkhs-light-theme-skeleton:exe:fltkhs-light-theme-skeleton +-- @ diff --git a/src/Graphics/UI/FLTK/Theme/Light/Assets.hs b/src/Graphics/UI/FLTK/Theme/Light/Assets.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/FLTK/Theme/Light/Assets.hs @@ -0,0 +1,240 @@ +{-# LANGUAGE ImplicitParams, ScopedTypeVariables, OverloadedStrings #-} +{-| +Module: Graphics.UI.FLTK.Theme.Assets + +A module that allows access to the resources (fonts, images, etc.) bundled with this theme. Clients of this package should not need to directly include this module since @Graphics.UI.FLTK.Theme.Light@ re-exports it. +-} +module Graphics.UI.FLTK.Theme.Light.Assets + ( + -- * Assets + -- ** Description & Usage #AssetsDescriptionAndUsage# + -- $Assets + -- + + -- ** Why ImplicitParams? #WhyImplicitParams# + -- + -- $WhyImplicitParams + Assets + , loadAssets + + -- * Fonts + -- + -- $Fonts + , dejaVuSans + , josefinSlabSemiBold + , yanoneKaffesatz + + -- * Images + -- + -- $Images + , cancelButtonImage + , downSmallImage + , forwardImage + , leftImage + , okButtonImage + , returnButtonImage + , rewindImage + , rightImage + , upSmallImage + ) +where +import Graphics.UI.FLTK.LowLevel.Fl_Enumerations +import Graphics.UI.FLTK.LowLevel.FLTKHS +import qualified Data.Text as T +import Data.List +import qualified Graphics.UI.FLTK.LowLevel.FL as FL +import qualified Data.ByteString as B +import Control.Exception +import Graphics.UI.Font.Load +import Data.Maybe +import Control.Monad +import Paths_fltkhs_themes + +-- | An opaque type that contains all of the resources needed by this theme. +-- Getting to the resources requires threading something of the type as an implicit +-- parameter to the accessors below, eg. 'dejaVuSans'. +data Assets = + Assets + { + _dejaVuSans :: Font + , _yanoneKaffesatz :: Font + , _josefinSlabSemiBold :: Font + , _returnButtonImage :: Ref PNGImage + , _okButtonImage :: Ref PNGImage + , _cancelButtonImage :: Ref PNGImage + , _downSmallImage :: Ref PNGImage + , _upSmallImage :: Ref PNGImage + , _forwardImage :: Ref PNGImage + , _rewindImage :: Ref PNGImage + , _leftImage :: Ref PNGImage + , _rightImage :: Ref PNGImage + } deriving Show + +-- | The [standard font](https://www.fontsquirrel.com/fonts/dejavu-sans) used for most labels, titles, output etc. +dejaVuSans :: (?assets :: Assets) => Font +dejaVuSans = _dejaVuSans ?assets + +-- | Currently unused but a [nice font](https://www.yanone.de/fonts/kaffeesatz/) around for the future ... +yanoneKaffesatz :: (?assets :: Assets) => Font +yanoneKaffesatz = _yanoneKaffesatz ?assets + +-- | A nice [banner font](https://www.fontsquirrel.com/fonts/josefin-slab). +josefinSlabSemiBold :: (?assets :: Assets) => Font +josefinSlabSemiBold = _josefinSlabSemiBold ?assets + +-- | <> +returnButtonImage :: (?assets :: Assets) => Ref PNGImage +returnButtonImage = _returnButtonImage ?assets + +-- | <> +okButtonImage :: (?assets :: Assets) => Ref PNGImage +okButtonImage = _okButtonImage ?assets +-- | <> +cancelButtonImage :: (?assets :: Assets) => Ref PNGImage +cancelButtonImage = _cancelButtonImage ?assets +-- | The down arrow. +-- +-- <> +downSmallImage :: (?assets :: Assets) => Ref PNGImage +downSmallImage = _downSmallImage ?assets +-- | The up arrow. +-- +-- <> +upSmallImage :: (?assets :: Assets) => Ref PNGImage +upSmallImage = _upSmallImage ?assets +-- | <> +forwardImage :: (?assets :: Assets) => Ref PNGImage +forwardImage = _forwardImage ?assets +-- | <> +rewindImage :: (?assets :: Assets) => Ref PNGImage +rewindImage = _rewindImage ?assets +-- | <> +leftImage :: (?assets :: Assets) => Ref PNGImage +leftImage = _leftImage ?assets +-- | <> +rightImage :: (?assets :: Assets) => Ref PNGImage +rightImage = _rightImage ?assets + +fonts :: [FilePath] +fonts = + [ + "fonts/DejaVuSans.ttf" + , "fonts/YanoneKaffeesatz-Regular.ttf" + , "fonts/JosefinSlab-SemiBold.ttf" + ] + +fontNames :: [T.Text] +fontNames = + [ + "DejaVu Sans" + , "Yanone Kaffeesatz Regular" + , "Josefin Slab" + ] + +imagePaths :: [FilePath] +imagePaths = + [ + "images/dialog-ok.png" + , "images/dialog-apply.png" + , "images/dialog-cancel.png" + , "images/down-small.png" + , "images/up-small.png" + , "images/forward.png" + , "images/rewind.png" + , "images/left.png" + , "images/right.png" + ] + +-- | Used at app start time to load the resources of this theme into memory. +-- This should never be called directly, but through +-- 'Graphics.UI.FLTK.Theme.Light.Common.configureTheme' which does some other +-- setup. +loadAssets :: IO Assets +loadAssets = do + fontPaths <- mapM getDataFileName fonts + loaded <- mapM loadFont fontPaths + let errors = catMaybes (Data.List.map (\p -> case p of { Left err -> Just err; _ -> Nothing}) loaded) + when (not (Data.List.null errors)) + (ioError (userError ("loadAssets (fatal error): unable to load font assets for the Light theme:\n" ++ + (Data.List.concat (Data.List.intersperse "\n" errors))))) + ips <- mapM getDataFileName imagePaths + images <- mapM + (\p -> do + bytes <- B.readFile p `catch` + (\(e :: SomeException) -> ioError + (userError ("loadAssets (fatal error): image does not exist at path: " ++ p))) + iE <- pngImageNewWithData (T.pack "") bytes + case iE of + Left _ -> ioError (userError ("loadAssets (fatal error): unable to read image data into a PNGImage:\n" ++ p)) + Right i -> return i) + ips + numFaces <- FL.setFonts Nothing + let fonts = Prelude.map Font [0 .. numFaces - 1 ] + withFaces <- mapM + ( + \f -> do + (face,_) <- FL.getFontName f + return (face,f) + ) + fonts + let fontNumbers = catMaybes (Data.List.map (\fName -> Prelude.lookup fName withFaces) fontNames) + _ <- FL.setScheme "gtk+" + let addImages as = as (images !! 0) + (images !! 1) + (images !! 2) + (images !! 3) + (images !! 4) + (images !! 5) + (images !! 6) + (images !! 7) + (images !! 8) + assets = + if (Data.List.length fontNumbers /= Data.List.length fontNames) + then addImages (Assets helvetica helvetica helvetica ) + else addImages (Assets (fontNumbers !! 0) (fontNumbers !! 1) (fontNumbers !! 2)) + return assets + +-- $Assets +-- This module mediates access to fonts, images and whatever other data is needed +-- by this theme. To provide a consistent look-and-feel across platforms the theme +-- bundles whatever it needs and loads them when a user's app is started. The +-- loaded assets should not interfere with any other process thread. For example, +-- when a user's application starts up the 'dejaVuSansMono' font is loaded into the +-- font cache, but it should be isolated to the app's process. +-- +-- +-- To use the assets in an FLTK app you need to enable the @ImplicitParams@ +-- pragma and then pass the 'Assets' implicit constraint to every function that +-- needs the resources: +-- +-- @ +-- {-\# LANGUAGE ImplicitParams ...\#-} +-- ... +-- myAwesomeUI :: (?assets :: Assets) => ... +-- myAwesomeUI = do +-- ... +-- b <- buttonNew ... +-- setLabelFont b dejaVuSansMono +-- ... +-- @ +-- +-- For more extensive documentation on how to use assets in the context of a +-- full application see "Graphics.UI.FLTK.Theme.Light#GettingStarted". + +-- $WhyImplicitParams +-- [ImplicitParams](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#implicit-parameters) +-- is a fairly contentious extension because of how it interacts with +-- [recursion](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#implicit-parameters-and-polymorphic-recursion) +-- and the dangers of accidental name-shadowing. The two alternatives are +-- [Reader](http://hackage.haskell.org/package/mtl-2.2.2/docs/Control-Monad-Reader.html) +-- and [reflection](http://hackage.haskell.org/package/reflection). While both +-- are more principled the first requires all UI functions have a 'MonadReader' +-- constraint which makes the API way uglier and harder to use, and the second +-- incurs a dependency on +-- [template-haskell](http://hackage.haskell.org/package/template-haskell) which +-- I also did not want. /ImplicitParams/ are easier to use and have been in GHC +-- since 6.8.1 and since we're just threading through some fonts and images +-- hopefully the downsides won't become a big deal in practice. + +-- $Fonts +-- The fonts required by this theme, all are TTF. diff --git a/src/Graphics/UI/FLTK/Theme/Light/Browser.hs b/src/Graphics/UI/FLTK/Theme/Light/Browser.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/FLTK/Theme/Light/Browser.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE ImplicitParams, OverloadedStrings, AllowAmbiguousTypes, GADTs, CPP, ExistentialQuantification, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, ScopedTypeVariables, UndecidableInstances #-} +module Graphics.UI.FLTK.Theme.Light.Browser + ( + browserNew, + selectBrowserNew, + fileBrowserNew, + browserDraw, + browserSetup + ) +where +import Graphics.UI.FLTK.LowLevel.Fl_Types +import Graphics.UI.FLTK.Theme.Light.Common +import qualified Data.Text as T +import qualified Graphics.UI.FLTK.LowLevel.FLTKHS as LowLevel +import Graphics.UI.FLTK.LowLevel.Dispatch +import Graphics.UI.FLTK.LowLevel.Fl_Enumerations +import Graphics.UI.FLTK.Theme.Light.Assets + +-- | The custom 'draw' function for creating the themed browser +browserDraw :: Ref LowLevel.Browser -> IO () +browserDraw b = do + (color :: Color) <- LowLevel.getColor b + let slightlyDarker = colorAverage color blackColor 0.85 + withCustomBoxDraw + BorderBox + (\rect _ -> do + LowLevel.flcRectfWithColor rect color + LowLevel.flcRectWithColor rect slightlyDarker) + (LowLevel.drawSuper b) + +-- | Setting the theme's color, fonts etc +browserSetup :: (?assets :: Assets) => Ref LowLevel.Browser -> IO () +browserSetup b = do + LowLevel.setColor b lightBackground + LowLevel.setBox b BorderBox + LowLevel.setLabelfont b commonFont + LowLevel.setLabelsize b commonFontSize + LowLevel.setTextfont b commonFont + c <- commonSelectionColor + LowLevel.setScrollbarSize b 10 + LowLevel.setSelectionColor b c + LowLevel.setTextsize b commonFontSize + +browserNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.Browser) +browserNew rect l = do + b <- LowLevel.browserCustom rect l (Just browserDraw) Nothing + browserSetup b + return b + +selectBrowserNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.SelectBrowser) +selectBrowserNew rect l = do + b <- browserNew rect l + LowLevel.setType b SelectBrowserType + return (castTo b) + +fileBrowserNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.FileBrowser) +fileBrowserNew rect l = do + b <- LowLevel.fileBrowserCustom rect l (Just (browserDraw . safeCast)) Nothing + browserSetup (safeCast b) + return b diff --git a/src/Graphics/UI/FLTK/Theme/Light/Button.hs b/src/Graphics/UI/FLTK/Theme/Light/Button.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/FLTK/Theme/Light/Button.hs @@ -0,0 +1,499 @@ +{-# LANGUAGE ImplicitParams, OverloadedStrings, AllowAmbiguousTypes, GADTs, CPP, ExistentialQuantification, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, ScopedTypeVariables, UndecidableInstances #-} +module Graphics.UI.FLTK.Theme.Light.Button + ( + FillSpec(..), + buttonFillSpec, + buttonIsHidden, + buttonNew, + buttonSetup, + cancelButtonNew, + checkButtonNew, + drawCheck, + drawIndicatorButton, + drawLight, + drawMenuButton, + drawRegularButton, + drawRound, + fillRectangle, + lightButtonNew, + menuButtonNew, + okButtonNew, + returnButtonNew, + roundButtonNew, + toggleButtonNew + ) +where +import Control.Exception +import Control.Monad +import Graphics.UI.FLTK.LowLevel.Dispatch +import Graphics.UI.FLTK.LowLevel.Fl_Enumerations +import Graphics.UI.FLTK.LowLevel.Fl_Types +import Graphics.UI.FLTK.Theme.Light.Common +import Text.Printf +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Graphics.UI.FLTK.LowLevel.FL as FL +import qualified Graphics.UI.FLTK.LowLevel.FLTKHS as LowLevel +import qualified Graphics.UI.FLTK.LowLevel.Dispatch +import Graphics.UI.FLTK.Theme.Light.Assets + +-- | Check of the given button is 'HiddenButtonType' +buttonIsHidden :: Ref LowLevel.Button -> IO Bool +buttonIsHidden b = do + t <- LowLevel.getType_ b + case t of + HiddenButtonType -> return True + _ -> return False + +-- | Draw a regular button, i.e not a radio button, toggle button, etc. +drawRegularButton :: FillSpec -> Ref LowLevel.Button -> IO () +drawRegularButton spec b = do + buttonType <- LowLevel.getType_ b + case buttonType of + HiddenButtonType -> return () + _ -> do + pressed <- LowLevel.getValue b + fillRectangle spec pressed + focused <- isWidget b FL.focus + hovering <- isWidget b FL.belowmouse + borderRectangle spec focused hovering + LowLevel.drawLabel b Nothing + +-- | Radio and light buttons are examples of an "indicator" button, some visual indicator that the +-- button is enabled. It takes a function that draws the indicator and 'Bool' flags specifying +-- whether it is pressed, transparent or entirely hidden respectively, the 'FontSize' of the +-- label so the indicator can properly position itself next to the label and the widget itself. +drawIndicatorButton :: + ( + Parent orig LowLevel.Widget, + Match b ~ FindOp orig orig (LowLevel.ActiveR ()), + Op (LowLevel.ActiveR ()) b orig (IO Bool), + Match c ~ FindOp orig orig (LowLevel.GetAlign ()), + Op (LowLevel.GetAlign ()) c orig (IO Alignments), + Match d ~ FindOp orig orig (LowLevel.GetImage ()), + Op (LowLevel.GetImage ()) d orig (IO (Maybe (Ref LowLevel.Image))), + Match e ~ FindOp orig orig (LowLevel.GetSelectionColor ()), + Op (LowLevel.GetSelectionColor ()) e orig (IO Color), + Match g ~ FindOp orig orig (LowLevel.GetRectangle ()), + Op (LowLevel.GetRectangle ()) g orig (IO Rectangle), + Match h ~ FindOp orig orig (LowLevel.GetColor ()), + Op (LowLevel.GetColor ()) h orig (IO Color), + Match i ~ FindOp orig orig (LowLevel.GetLabelsize ()), + Op (LowLevel.GetLabelsize ()) i orig (IO FontSize), + Match j ~ FindOp orig orig (LowLevel.DrawLabel ()), + Op (LowLevel.DrawLabel ()) j orig (Maybe (Rectangle,Alignments) -> IO ()), + Match k ~ FindOp orig orig (LowLevel.GetBox ()), + Op (LowLevel.GetBox ()) k orig (IO (Boxtype)), + Match l ~ FindOp orig orig (LowLevel.GetParent ()), + Op (LowLevel.GetParent ()) l orig (IO (Maybe (Ref LowLevel.Group))), + Match m ~ FindOp orig orig (LowLevel.GetColor ()), + Op (LowLevel.GetColor ()) m orig (IO (Color)), + Match n ~ FindOp orig orig (LowLevel.SetColor ()), + Op (LowLevel.SetColor ()) n orig (Color -> IO ()) + ) => (FillSpec -> Bool -> Color -> FontSize -> IO Rectangle) -> Bool -> Bool -> Bool -> FontSize -> Ref orig -> IO () +drawIndicatorButton indicator pressed transparent hidden fs b = + if hidden then return () + else do + spec <- buttonFillSpec b + boxType <- LowLevel.getBox b + active <- LowLevel.activeR b + if (not transparent) + then case boxType of + NoBox -> return () + _ -> do + fillRectangle spec pressed + focused <- isWidget b FL.focus + hovering <- isWidget b FL.belowmouse + borderRectangle spec focused hovering + else do + maybeParent <- LowLevel.getParent b + case maybeParent of + Just (p :: Ref LowLevel.Group) -> do + c <- LowLevel.getColor p + () <- LowLevel.setColor b c + focused <- isWidget b FL.focus + hovering <- isWidget b FL.belowmouse + borderRectangle (spec { fillBorderColor = lightBackground }) focused hovering + Nothing -> return () + let (x,y,w,h) = fromRectangle (fillBounds spec) + color <- LowLevel.getSelectionColor b + indicatorBounds <- indicator spec (pressed && active) color fs + let (indicatorX, _, indicatorW, _) = fromRectangle indicatorBounds + (alignments :: Alignments) <- LowLevel.getAlign b + (imageM :: Maybe (Ref LowLevel.Image)) <- LowLevel.getImage b + let labelBounds = case imageM of + Nothing -> toRectangle (x + fillCornerRadius spec, y, w - (fillCornerRadius spec * 2), h) + Just _ -> + let widthLeftCut = indicatorX + indicatorW - x + widthRightCut = fillCornerRadius spec + in toRectangle (indicatorX + indicatorW, y, w - (widthLeftCut + widthRightCut),h) + LowLevel.drawLabel b (Just (labelBounds, alignments)) + +-- | Draw a down arrow on the right side of the given 'Rectangle' and return it's bounds +drawDownArrow :: Rectangle -> Color -> FontSize -> IO Rectangle +drawDownArrow bounds arrowColor (FontSize size)= + let arrowSize :: Int + arrowSize = (fromIntegral size) `intDiv` 2 + (x,y,w,h) = fromRectangle bounds + arrowX = x + w - arrowSize - arrowSize + arrowY :: Int + arrowY = y + (h `intDiv` 2) - (arrowSize `intDiv` 2) + arrowBoundingBox = toRectangle (arrowX, arrowY, arrowSize, arrowSize) + in do + oldColor <- LowLevel.flcColor + LowLevel.flcSetColor arrowColor + LowLevel.flcBeginPolygon + LowLevel.flcVertex (PrecisePosition (PreciseX (fromIntegral arrowX)) (PreciseY (fromIntegral arrowY))) + LowLevel.flcVertex (PrecisePosition (PreciseX (fromIntegral (arrowX+arrowSize))) (PreciseY (fromIntegral arrowY))) + LowLevel.flcVertex (PrecisePosition (PreciseX ((fromIntegral arrowX) + (fromIntegral arrowSize)/2)) (PreciseY (fromIntegral (arrowY + arrowSize)))) + LowLevel.flcVertex (PrecisePosition (PreciseX (fromIntegral arrowX)) (PreciseY (fromIntegral arrowY))) + LowLevel.flcEndPolygon + return arrowBoundingBox + +-- | Draw a themed menu button +drawMenuButton :: Ref LowLevel.MenuButton -> IO () +drawMenuButton m = do + t <- LowLevel.getType_ m + b <- LowLevel.getBox m + let noBox = case b of { NoBox -> True; _ -> False } + if (t /= 0 || noBox) then return () + else do + fillSpec <- buttonFillSpec m + itemIndex <- LowLevel.getValue m + fontSize <- LowLevel.getLabelsize m + drawIndicatorButton (\spec _ color fs -> drawDownArrow (fillBounds spec) color fs) (maybe False (const True) itemIndex) False False fontSize m + +-- | Draw the light part of a LightButton. The 'Bool' indicates whether the light is on. +drawLight :: FillSpec -> Bool -> Color -> FontSize -> IO Rectangle +drawLight spec lightOn lightColor (FontSize lightDiameter) = + let (x,y,w,h) = fromRectangle (fillBounds spec) + lightX = x + 3 + lightY = y + (h `intDiv` 2) + lightRadius = (fromIntegral lightDiameter / 2.0) + lightBoundingBox = toRectangle (lightX, (lightY - truncate lightRadius), fromIntegral lightDiameter, fromIntegral lightDiameter) + in do + oldColor <- LowLevel.flcColor + when lightOn + (do + LowLevel.flcSetColor lightColor + LowLevel.flcPie lightBoundingBox (PreciseAngle 0.0) (PreciseAngle 360.0) + ) + LowLevel.flcSetColor (fillBorderColor spec) + LowLevel.flcCircle (PrecisePosition (PreciseX (fromIntegral (lightX + truncate lightRadius))) (PreciseY (fromIntegral lightY))) lightRadius + LowLevel.flcSetColor oldColor + return lightBoundingBox + +-- | Draw the radio part of a RoundButton. The 'Bool' indicates whether it is enabled. +drawRound :: FillSpec -> Bool -> Color -> FontSize -> IO Rectangle +drawRound spec radioOn radioColor (FontSize fs) = + let (x,y,w,h) = fromRectangle (fillBounds spec) + radioBoxX = x + 3 + radioBoxY = fromIntegral y + (fromIntegral h / 2.0) + radioBoxWidth :: Int + radioBoxWidth = fromIntegral fs + radioBoxHalfway :: Double + radioBoxHalfway = (fromIntegral radioBoxWidth) / 2.0 + radioBoundingBox = + toRectangle (radioBoxX, truncate (radioBoxY - radioBoxHalfway), radioBoxWidth, radioBoxWidth) + circleSvg = + "\n" ++ + "" ++ + "\n" + radioRadius = (fromIntegral radioBoxWidth) / 4.5 + radioDiameter = radioRadius * 2 + radioX = fromIntegral radioBoxX + radioBoxHalfway - radioRadius + radioY = radioBoxY - radioRadius + in do + (borderColorR, borderColorG, borderColorB) <- FL.getColorRgb (fillBorderColor spec) + (radioColorR, radioColorG, radioColorB) <- FL.getColorRgb (if radioOn then radioColor else (fillTopColor spec)) + let svg = + "\n" ++ + (printf circleSvg + radioBoxWidth radioBoxWidth (-radioBoxHalfway) (-radioBoxHalfway) radioBoxWidth radioBoxWidth + (radioBoxHalfway-1.0) ("none" :: String) ("rgb(" ++ show borderColorR ++ "," ++ show borderColorG ++ "," ++ show borderColorB ++ ")")) ++ + (printf circleSvg + radioBoxWidth radioBoxWidth (-radioBoxHalfway) (-radioBoxHalfway) radioBoxWidth radioBoxWidth + (radioRadius-1.0) ("rgb(" ++ show radioColorR ++ "," ++ show radioColorG ++ "," ++ show radioColorB ++ ")") ("rgb(" ++ show radioColorR ++ "," ++ show radioColorG ++ "," ++ show radioColorB ++ ")")) ++ + "\n" + iE <- LowLevel.svgImageNew ((TE.encodeUtf8 . T.pack) svg) + case iE of + Left _ -> throwIO (userError ("The generated SVG is invalid: \n" ++ svg)) + Right i -> do + LowLevel.draw i (toPosition (radioBoxX,truncate (radioBoxY - radioBoxHalfway))) + LowLevel.destroy i + return radioBoundingBox + +-- | Draw the check part of a CheckButton. The 'Bool' indicated whether to draw the check or not. +drawCheck :: FillSpec -> Bool -> Color -> FontSize -> IO Rectangle +drawCheck spec checked checkColor (FontSize fontSize) = + let (x,y,w,h) = fromRectangle (fillBounds spec) + checkBoxWidth :: Int = fromIntegral fontSize + checkBoxHeight = checkBoxWidth + checkBoxX = x + 3 + checkBoxMiddle = fromIntegral checkBoxHeight / 2.0 + checkBoxFourth = fromIntegral checkBoxHeight / 4.0 + yOffset = (h - fromIntegral checkBoxHeight) `intDiv` 2 + pad = 1 + checkThickness = 2 + checkBoxY = y + yOffset + checkBoxRectangle = toRectangle (checkBoxX, checkBoxY, checkBoxWidth, checkBoxHeight) + in do + when checked + (let + downstrokeStart = Position (X (checkBoxX + pad)) (Y (checkBoxY + truncate checkBoxMiddle)) + upstrokeStart = Position (X (checkBoxX + pad + truncate checkBoxFourth)) (Y (checkBoxY - pad + checkBoxHeight)) + in do + LowLevel.flcSetColor checkColor + LowLevel.flcPolygonWith4Sides + downstrokeStart + (Position (X (checkBoxX + pad + checkThickness)) (Y (checkBoxY + truncate checkBoxMiddle))) + (Position (X (checkBoxX + pad + truncate checkBoxFourth + checkThickness)) (Y (checkBoxY - pad + checkBoxHeight))) + (Position (X (checkBoxX + pad + truncate checkBoxFourth)) (Y (checkBoxY - pad + checkBoxHeight))) + LowLevel.flcPolygonWith4Sides + upstrokeStart + (Position (X (checkBoxX + checkBoxWidth - pad - checkThickness)) (Y (checkBoxY + pad))) + (Position (X (checkBoxX + checkBoxWidth - pad)) (Y (checkBoxY + pad))) + (Position (X (checkBoxX + pad + truncate checkBoxFourth + checkThickness)) (Y (checkBoxY - pad + checkBoxHeight))) + ) + oldColor <- LowLevel.flcColor + LowLevel.flcSetColor (fillBorderColor spec) + LowLevel.flcRect checkBoxRectangle + LowLevel.flcSetColor oldColor + return checkBoxRectangle + +-- | Create a 'FillSpec' for the given button based on its color, bounds etc. +buttonFillSpec :: + ( + Match w ~ FindOp orig orig (LowLevel.GetRectangle ()), + Op (LowLevel.GetRectangle ()) w orig (IO Rectangle), + Match x ~ FindOp orig orig (LowLevel.GetColor ()), + Op (LowLevel.GetColor ()) x orig (IO Color), + Match y ~ FindOp orig orig (LowLevel.GetLabelsize ()), + Op (LowLevel.GetLabelsize ()) y orig (IO FontSize), + Match z ~ FindOp orig orig (LowLevel.GetSelectionColor ()), + Op (LowLevel.GetSelectionColor ()) z orig (IO Color) + ) => Ref orig -> IO FillSpec +buttonFillSpec b = do + rect <- LowLevel.getRectangle b + color <- LowLevel.getColor b + selectionColor <- LowLevel.getSelectionColor b + makeFillSpec rect color selectionColor + +-- | Common setup for all buttons, setting the label fonts, background color etc. +buttonSetup :: + ( + ?assets :: Assets, + Match w ~ FindOp orig orig (LowLevel.SetColor ()), + Op (LowLevel.SetColor ()) w orig (Color -> IO ()), + Match x ~ FindOp orig orig (LowLevel.SetLabelfont ()), + Op (LowLevel.SetLabelfont ()) x orig (Font -> IO ()), + Match y ~ FindOp orig orig (LowLevel.SetLabelsize ()), + Op (LowLevel.SetLabelsize ()) y orig (FontSize -> IO ()), + Match z ~ FindOp orig orig (LowLevel.SetAlign ()), + Op (LowLevel.SetAlign ()) z orig (Alignments -> IO ()) + ) => Ref orig -> IO () +buttonSetup b = do + color <- commonColor + () <- LowLevel.setColor b color + () <- LowLevel.setLabelfont b commonFont + () <- LowLevel.setLabelsize b commonFontSize + LowLevel.setAlign b (Alignments [AlignTypeInside, AlignTypeCenter , AlignTypeImageNextToText]) + +buttonNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.Button) +buttonNew rectangle label = do + b <- LowLevel.buttonCustom + rectangle + label + (Just (\b -> do + spec <- buttonFillSpec b + drawRegularButton spec b)) + (Just (LowLevel.defaultCustomWidgetFuncs { LowLevel.handleCustom = Just handleHover })) + buttonSetup b + return b + +toggleButtonNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.ToggleButton) +toggleButtonNew rectangle label = do + b <- LowLevel.buttonCustom + rectangle + label + (Just (\b -> do + spec <- buttonFillSpec b + drawRegularButton spec b)) + (Just (LowLevel.defaultCustomWidgetFuncs { LowLevel.handleCustom = (Just handleHover ) })) + LowLevel.setType b ToggleButtonType + buttonSetup b + return (LowLevel.castTo b) + +lightButtonNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.LightButton) +lightButtonNew rectangle label = do + b <- LowLevel.lightButtonCustom + rectangle + label + (Just (\b -> do + pressed <- LowLevel.getValue b + hidden <- buttonIsHidden (safeCast b) + fontSize <- LowLevel.getLabelsize b + drawIndicatorButton drawLight pressed False hidden fontSize b)) + (Just (LowLevel.defaultCustomWidgetFuncs { LowLevel.handleCustom = (Just handleHover) })) + buttonSetup b + LowLevel.setSelectionColor b yellowColor + LowLevel.setAlign b (Alignments [AlignTypeInside, AlignTypeCenter, AlignTypeImageNextToText]) + return b + +checkButtonNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.CheckButton) +checkButtonNew rectangle label = do + b <- LowLevel.checkButtonCustom + rectangle + label + (Just (\b -> do + hidden <- buttonIsHidden (safeCast b) + when (not hidden) + (do + (x,y,w,h) <- fmap fromRectangle (LowLevel.getRectangle b) + bx <- FL.boxDx BorderBox + c <- LowLevel.getColor b + (FontSize labelWCInt) <- LowLevel.getLabelsize b + let labelW = fromIntegral labelWCInt + let dx = bx + 2 + dy = (h-labelW) `intDiv` 2 + LowLevel.flcDrawBox BorderBox (toRectangle (x+dx,y+dy,labelW,labelW)) c + v <- LowLevel.getValue b + when v + (do + let tx = x+dx+1 + tw = labelW-1 + d1 = tw `intDiv` 3 + d2 = tw-d1 + ty = y+dy+((labelW+d2) `intDiv` 2)-d1-2 + oldC <- LowLevel.flcColor + LowLevel.flcSetColor blackColor + mapM_ + (\i -> do + let ty' = ty+i + LowLevel.flcLine (toPosition (tx,ty')) (toPosition (tx+d1,ty'+d1)) + LowLevel.flcLine (toPosition (tx+d1,ty'+d1)) (toPosition (tx+tw-1,ty'+d1-d2+1))) + [0 .. 2] + LowLevel.flcSetColor oldC + ) + let lx = dx+labelW+2 + alignments <- LowLevel.getAlign b + LowLevel.drawLabel b (Just (toRectangle (x+lx,y,w-lx-bx,h), alignments))))) + Nothing + color <- commonColor + () <- LowLevel.setColor b color + () <- LowLevel.setLabelfont b commonFont + () <- LowLevel.setLabelsize b commonFontSize + LowLevel.setSelectionColor b color + return b + +roundButtonNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.RoundButton) +roundButtonNew rectangle label = do + b <- LowLevel.roundButtonCustom + rectangle + label + (Just (\b -> do + hidden <- buttonIsHidden (safeCast b) + when (not hidden) + (do + (x,y,w,h) <- fmap fromRectangle (LowLevel.getRectangle b) + bx <- FL.boxDx BorderBox + c <- LowLevel.getColor b + (FontSize labelWCInt) <- LowLevel.getLabelsize b + v <- LowLevel.getValue b + let labelW :: Int + labelW = fromIntegral labelWCInt + dx = bx + 2 + dy = (h-labelW) `intDiv` 2 + circleSvg = + "\n" ++ + "" ++ + "\n" + halfway :: Double + halfway = (fromIntegral labelW)/2 + radius :: Double + radius = (fromIntegral labelW)/4.5 + (Color black') = blackColor + black :: Int + black = fromIntegral black' + svg = + "\n" ++ + (printf circleSvg + labelW labelW (-halfway) (-halfway) labelW labelW + (halfway-1.0) ("none" :: String) black) ++ + (if v + then + printf circleSvg + labelW labelW (-halfway) (-halfway) labelW labelW + (radius-1.0) ("black" :: String) black + else "") + ++ + "\n" + iE <- LowLevel.svgImageNew ((TE.encodeUtf8 . T.pack) svg) + case iE of + Left _ -> throwIO (userError ("The generated SVG is invalid: \n" ++ svg)) + Right i -> do + LowLevel.draw i (toPosition (x+dx,y+dy)) + LowLevel.destroy i + let lx = dx+labelW+2 + alignments <- LowLevel.getAlign b + LowLevel.drawLabel b (Just (toRectangle (x+lx,y,w-lx-bx,h), alignments))))) + Nothing + color <- commonColor + () <- LowLevel.setColor b color + () <- LowLevel.setLabelfont b commonFont + () <- LowLevel.setLabelsize b commonFontSize + LowLevel.setSelectionColor b color + return b + +menuButtonNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.MenuButton) +menuButtonNew rect l = do + m <- LowLevel.menuButtonCustom rect l (Just drawMenuButton) Nothing + buttonSetup m + LowLevel.setBox m BorderBox + LowLevel.setTextfont m commonFont + LowLevel.setTextsize m commonFontSize + color <- commonSelectionColor + LowLevel.setSelectionColor m color + return m + +returnButtonNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.ReturnButton) +returnButtonNew rect l = do + b <- LowLevel.returnButtonCustom rect l + (Just ((\b -> do + spec <- buttonFillSpec b + drawRegularButton spec b) . safeCast)) + (Just (LowLevel.defaultCustomWidgetFuncs { LowLevel.handleCustom = Just handleHover })) + buttonSetup b + let (_,_,w',h') = fromRectangle rect + LowLevel.setAlign b (Alignments [AlignTypeTextNextToImage]) + iM <- LowLevel.copy returnButtonImage Nothing + case iM of + Nothing -> return () + Just i -> do + LowLevel.scale i (Size (Width (w' `intDiv` 3)) (Height (h' `intDiv` 2))) Nothing Nothing + LowLevel.setImage b iM + return b + +okButtonNew :: (?assets :: Assets) => Rectangle -> IO (Ref LowLevel.Button) +okButtonNew rect = do + b <- buttonNew rect (Just "OK") + iM <- LowLevel.copy okButtonImage Nothing + let (_,_,w',h') = fromRectangle rect + case iM of + Nothing -> return () + Just i -> do + LowLevel.scale i (Size (Width (w' `intDiv` 3)) (Height (h' `intDiv` 2))) Nothing Nothing + LowLevel.setImage b iM + return b + +cancelButtonNew :: (?assets :: Assets) => Rectangle -> IO (Ref LowLevel.Button) +cancelButtonNew rect = do + b <- buttonNew rect (Just "Cancel") + iM <- LowLevel.copy cancelButtonImage Nothing + let (_,_,w',h') = fromRectangle rect + case iM of + Nothing -> return () + Just i -> do + LowLevel.scale i (Size (Width (w' `intDiv` 3)) (Height (h' `intDiv` 2))) Nothing Nothing + LowLevel.setImage b iM + return b diff --git a/src/Graphics/UI/FLTK/Theme/Light/Clock.hs b/src/Graphics/UI/FLTK/Theme/Light/Clock.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/FLTK/Theme/Light/Clock.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE ImplicitParams, ScopedTypeVariables, OverloadedStrings, AllowAmbiguousTypes, GADTs, CPP, ExistentialQuantification, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, ScopedTypeVariables, UndecidableInstances #-} +module Graphics.UI.FLTK.Theme.Light.Clock + ( + clockNew, + drawClock + ) +where +import Control.Exception +import Graphics.UI.FLTK.LowLevel.Fl_Enumerations +import Graphics.UI.FLTK.LowLevel.Fl_Types +import Graphics.UI.FLTK.Theme.Light.Common +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Graphics.UI.FLTK.LowLevel.FL as FL +import qualified Graphics.UI.FLTK.LowLevel.FLTKHS as LowLevel +import Text.Printf +import Graphics.UI.FLTK.Theme.Light.Assets + +clockSvg :: Width -> Height -> RGB -> RGB -> LowLevel.ClockByTime -> String +clockSvg (Width w) (Height h) colorRgb selectionColorRgb (LowLevel.ClockByTime (LowLevel.Hour hours) (LowLevel.Minute minutes) (LowLevel.Second seconds)) = + let widthRadius :: Double + widthRadius = (fromIntegral w)/2 + heightRadius :: Double + heightRadius = (fromIntegral h)/2 + ellipseRadius :: PreciseSize + ellipseRadius = PreciseSize (PreciseWidth widthRadius) (PreciseHeight heightRadius) + withinSvg :: String -> String + withinSvg innards = + (printf + ("\n") + w h (-widthRadius) (-heightRadius) w h) + ++ innards ++ "\n" + strokeWidth = percentOfSmallerEllipseRadius 10 ellipseRadius + tickPadding = percentOfSmallerEllipseRadius 15 ellipseRadius + tickHeight = percentOfSmallerEllipseRadius 10 ellipseRadius + centerRadius = percentOfSmallerEllipseRadius 5 ellipseRadius + secondHandWidth = percentOfSmallerEllipseRadius 3 ellipseRadius + minuteHandWidth = percentOfSmallerEllipseRadius 3 ellipseRadius + minuteHandHeight = percentOfSmallerEllipseRadius 80 ellipseRadius + hourHandWidth = percentOfSmallerEllipseRadius 3 ellipseRadius + hourHandHeight = percentOfSmallerEllipseRadius 70 ellipseRadius + outline (colorR,colorG,colorB) = + printf "\n" + (truncate (widthRadius-strokeWidth/2) :: Int) + (truncate (heightRadius-strokeWidth/2) :: Int) + ("rgb(" ++ show colorR ++ "," ++ show colorG ++ "," ++ show colorB ++ ")") + strokeWidth + ticks (colorR,colorG,colorB) = + map + (\tickNumber -> + let tickAngle :: Int + tickAngle = tickNumber * 30 + PrecisePosition (PreciseX unitX) (PreciseY unitY) = angleToCoordinate (PreciseAngle (fromIntegral tickAngle)) + quarterHourTick = tickNumber == 0 || tickNumber == 3 || tickNumber == 6 || tickNumber == 9 + tickSvg = + printf "\n" + (unitX * (widthRadius-tickPadding-tickHeight)) (unitY * (widthRadius-tickPadding-tickHeight)) + (unitX * (widthRadius-tickPadding)) (unitY * (widthRadius-tickPadding)) + (if quarterHourTick then "black" + else ("rgb(" ++ show colorR ++ "," ++ show colorG ++ "," ++ show colorB ++ ")")) + in withinSvg tickSvg) + [0 .. 11] + center (colorR,colorG,colorB) = + let centerColor = "rgb(" ++ show colorR ++ "," ++ show colorG ++ "," ++ show colorB ++ ")" + in + printf "" + centerRadius + centerColor + centerColor + hourHand :: String + hourHand = + let fromMilitary :: Int + fromMilitary = hours `mod` 12 + hourPart :: Double + hourPart = (fromIntegral fromMilitary) * 30 + minutePart :: Double + minutePart = 30.0 * (fromIntegral minutes / 60) + hourAngle :: Double + hourAngle = hourPart+minutePart-90.0 + PrecisePosition (PreciseX unitX) (PreciseY unitY) = angleToCoordinate (PreciseAngle hourAngle) + in + printf " String + secondHand (colorR,colorG,colorB) = + let secondAngle :: Int + secondAngle = seconds*6-90 + PrecisePosition (PreciseX unitX) (PreciseY unitY) = angleToCoordinate (PreciseAngle (fromIntegral secondAngle)) + in + withinSvg + (printf "\n" + ++ (withinSvg (outline colorRgb)) + ++ (concat (ticks colorRgb)) + ++ (withinSvg hourHand) + ++ (withinSvg minuteHand) + ++ (withinSvg (center selectionColorRgb)) + ++ (withinSvg (secondHand selectionColorRgb)) + ++ "" + +-- | Custom clock drawing function +drawClock :: Ref LowLevel.Clock -> IO () +drawClock clock = do + bounds@(Rectangle clockPos (Size w' h')) <- LowLevel.getRectangle clock + color <- LowLevel.getColor clock + oldColor <- LowLevel.flcColor + colorRgb <- FL.getColorRgb (colorAverage color blackColor 0.80) + LowLevel.flcSetColor color + LowLevel.flcRectfWithColor bounds whiteColor + LowLevel.flcSetColor oldColor + selectionColorRgb <- LowLevel.getSelectionColor clock >>= FL.getColorRgb + time <- LowLevel.getValue clock + let svg = clockSvg w' h' colorRgb selectionColorRgb time + iE <- LowLevel.svgImageNew ((TE.encodeUtf8 . T.pack) svg) + case iE of + Left _ -> throwIO (userError ("The generated SVG is invalid: \n" ++ svg)) + Right i -> do + LowLevel.draw i clockPos + LowLevel.destroy i + LowLevel.drawLabel clock Nothing + +clockNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.Clock) +clockNew rectangle l' = do + c <- LowLevel.clockCustom rectangle l' (Just drawClock) Nothing + color <- commonColor + LowLevel.setColor c color + LowLevel.setBox c BorderBox + LowLevel.setLabelfont c commonFont + LowLevel.setLabelsize c commonFontSize + color <- commonFillColor + LowLevel.setSelectionColor c color + LowLevel.setShadow c False + return c diff --git a/src/Graphics/UI/FLTK/Theme/Light/ColorChooser.hs b/src/Graphics/UI/FLTK/Theme/Light/ColorChooser.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/FLTK/Theme/Light/ColorChooser.hs @@ -0,0 +1,830 @@ +{-# LANGUAGE ImplicitParams, FlexibleContexts, TypeFamilies, RecursiveDo, ScopedTypeVariables, OverloadedStrings #-} +module Graphics.UI.FLTK.Theme.Light.ColorChooser + ( + colorChooserNew, + flcColorChooser, + + -- * Drawing routines + ColorChooserComponentBounds(..), + ColorChooserComponentLayout(..), + ColorChooserState(..), + colorDialCallback, + drawCurrentColor, + drawHueBox, + drawPreviewColor, + drawSaturationSlider, + gaugeImageRectangle, + generateImage, + generateVImage, + handleHueBox, + hueBoxBounds, + makeColorChooserComponentBounds, + makeColorChooserComponentLayout, + maxSliderWidth, + modeMenuCallback, + setValuators, + sliderCallback, + updateHsv, + updateRgb + ) +where +import Control.Exception +import Control.Monad +import Control.Monad.ST +import Data.Fixed +import Data.IORef +import Data.Ratio +import Data.STRef +import Foreign.C.Types +import Graphics.UI.FLTK.LowLevel.Fl_Enumerations as Enumerations +import Graphics.UI.FLTK.LowLevel.Fl_Types +import Graphics.UI.FLTK.LowLevel.Dispatch +import Graphics.UI.FLTK.Theme.Light.Common +import Graphics.UI.FLTK.Theme.Light.Dial +import Graphics.UI.FLTK.Theme.Light.Group +import Graphics.UI.FLTK.Theme.Light.Menu +import Graphics.UI.FLTK.Theme.Light.Slider +import Graphics.UI.FLTK.Theme.Light.Window +import Graphics.UI.FLTK.Theme.Light.Group +import Graphics.UI.FLTK.Theme.Light.Button +import Numeric +import Text.Printf as Printf +import qualified Data.ByteString.Char8 as BChar +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Vector.Storable as DVS +import qualified Data.Vector.Storable.Mutable as DVSM +import qualified Graphics.UI.FLTK.LowLevel.FL as FL +import qualified Graphics.UI.FLTK.LowLevel.FLTKHS as LowLevel +import Graphics.UI.FLTK.Theme.Light.Assets + +-- | Bounds of the color chooser subcomponents +data ColorChooserComponentBounds = + ColorChooserComponentBounds + { + colorChooserHueBoxBounds :: Rectangle -- ^ The bounds of the hue box + , colorChooserSliderBounds :: Rectangle -- ^ The bounds of the saturation slider + , colorChooserPreviewPaneBounds :: Rectangle -- ^ The bounds of the byte\/hex\/decimal color readout and color swatch preview pane. + } deriving Show + + +-- | Layout of color chooser subcomponents +data ColorChooserComponentLayout = + ColorChooserComponentLayout + { + paddingWidthPercentage :: Double -- ^ Left\/right padding + , paddingHeightPercentage :: Double -- ^ Top\/bottom padding + , betweenPaddingPercent :: Double -- ^ % of color chooser width to set as padding /between/ subcomponents + , hueBoxWidthPercentage :: Double -- ^ % of color chooser width dedicated to the hue box + , sliderWidthPercentage :: Double -- ^ % of color chooser width dedicated to the saturation slider + , hueBoxHandleRadius :: Double -- ^ Radius of the indicator you drag around the hue box to change color + , previewPanePercentage :: Double -- ^ % of color chooser width dedicated to the preview pane + } deriving Show + + +-- | The state of color chooser, passed around as in 'IORef' and updated in callbacks, etc. +data ColorChooserState = + ColorChooserState + { + colorChooserValue :: Between0And1 + , colorChooserR :: Between0And1 + , colorChooserG :: Between0And1 + , colorChooserB :: Between0And1 + , colorChooserHue :: Between0And6 + , colorChooserSaturation :: Between0And1 + , colorChooserHueImage :: Ref LowLevel.RGBImage + , colorChooserMode :: ColorChooserMode + } deriving Show + +-- | Max width of the saturation slider if the color chooser is resized +maxSliderWidth :: Width +maxSliderWidth = Width 30 + +-- | The default layout of color chooser subcomponents +makeColorChooserComponentLayout :: Size -> Width -> Int -> ColorChooserComponentLayout +makeColorChooserComponentLayout (Size (Width w) (Height h)) (Width maxSliderWidth) gaugeHeight = + let calculatedSliderWidth = 0.15 `percentOf` w + gaugeStart = gaugeHeight `intDiv` 2 + maxSliderWidthPercentage :: Double + maxSliderWidthPercentage = (fromIntegral maxSliderWidth) / (fromIntegral w) + _sliderWidthPercentage :: Double + _sliderWidthPercentage = + if calculatedSliderWidth > maxSliderWidth + then maxSliderWidthPercentage + else 0.15 + _betweenPaddingPercent = 0.02 + hueBoxHandleRadius = + let r = (fromIntegral (if (w(fromIntegral gaugeStart)) then (fromIntegral gaugeStart) else r + _previewPanePercentage = 0.25 + in + ColorChooserComponentLayout + { + paddingWidthPercentage = 0.01 + , paddingHeightPercentage = 0.01 + , betweenPaddingPercent = _betweenPaddingPercent + , hueBoxWidthPercentage = 1.0 - (_betweenPaddingPercent + _sliderWidthPercentage + _previewPanePercentage) + , sliderWidthPercentage = _sliderWidthPercentage + , hueBoxHandleRadius = hueBoxHandleRadius + , previewPanePercentage = _previewPanePercentage + } + +hueBoxHandleSvg :: String +hueBoxHandleSvg = + "" + ++ "" + ++ "" + +-- | Draw the hue box subcomponent in the given 'Box', takes the 'Double' +-- indicator handle radius, the 'Int' slider gauge height so it can align itself +-- with it. +drawHueBox :: Double -> Int -> IORef ColorChooserState -> Ref LowLevel.ColorChooser -> Ref LowLevel.Box ->IO () +drawHueBox handleRadius gaugeHeight stateRef c b = do + state <- readIORef stateRef + bounds <- LowLevel.getRectangle b + let hueBox = hueBoxBounds bounds handleRadius gaugeHeight + color <- commonColor + let slightlyDarker = Enumerations.colorAverage color blackColor 0.80 + let spec = + BorderBoxSpec + { + borderBoxHoveringColor = slightlyDarker + , borderBoxColor = slightlyDarker + , borderBoxFocusedColor = slightlyDarker + , borderBoxFillColor = lightBackground + , borderBoxBounds = hueBox + } + let (x',y',w',h') = fromRectangle hueBox + LowLevel.flcRectfWithColor bounds (borderBoxFillColor spec) + drawBorderBox b spec True + iM <- LowLevel.copy (colorChooserHueImage state) (Just (Size (Width (w'-2)) (Height (h'-2)))) + maybe + (return ()) + (\i -> do + LowLevel.draw i (Position (X (x'+1)) (Y (y'+1))) + LowLevel.destroy i) + iM + damages <- LowLevel.getDamage b + let svg = + Printf.printf hueBoxHandleSvg + (handleRadius*2) (handleRadius*2) (-handleRadius) (-handleRadius) (handleRadius*2) (handleRadius*2) + handleRadius + iE <- LowLevel.svgImageNew ((TE.encodeUtf8 . T.pack) svg) + case iE of + Left _ -> throwIO (userError ("drawHueBox: the generated SVG is invalid: \n" ++ svg)) + Right i -> do + hue <- LowLevel.getHue c + saturation <- LowLevel.getSaturation c + case hue of + Left _ -> throwIO (userError ("drawHueBox: hue out of range, must be between 0 and 6.")) + Right (Between0And6 hue) -> + case saturation of + Left _ -> throwIO (userError ("drawHueBox: saturation out of range, must be between 0 and 1.")) + Right (Between0And1 saturation) -> + let (PrecisePosition (PreciseX xp') (PreciseY yp')) = + fromHs (hue, saturation) (PreciseSize (PreciseWidth (fromIntegral w')) (PreciseHeight (fromIntegral h'))) + pos = (Position (X (x'+(truncate (xp'-handleRadius)))) (Y (y'+(truncate (yp'-handleRadius))))) + in do + LowLevel.draw i pos + LowLevel.destroy i + LowLevel.drawLabel b Nothing + +-- | Calculate the bounds of the hue box based on the overall 'Rectangle' +-- bounds, the 'Double' radius of the indicator circle (half the indicator +-- circle can be outside the box so the center is always within it), and the +-- 'Int' saturation slider height so the hue box can position itself +-- accordingly. +hueBoxBounds :: Rectangle -> Double -> Int -> Rectangle +hueBoxBounds hueBoxOuterRect handleRadius gaugeHeight = + let (x',y',w',h') = fromRectangle hueBoxOuterRect + in + toRectangle + ( + x'+(truncate handleRadius) + , y'+ (gaugeHeight `intDiv` 2) + , w'-(truncate (handleRadius*2.0)) + , h'-gaugeHeight + ) + +-- | Calculate the overall bounds of all the subcomponents +makeColorChooserComponentBounds :: ColorChooserComponentLayout -> Rectangle -> Int -> ColorChooserComponentBounds +makeColorChooserComponentBounds layout rect gaugeHeight = + let (x',y',w',h') = fromRectangle rect + paddingWidth = (paddingWidthPercentage layout) `percentOf` w' + paddingHeight = (paddingHeightPercentage layout) `percentOf` h' + gaugeStart = gaugeHeight `intDiv` 2 + innerRectWidth = w'-(paddingWidth*2) + innerRectHeight = h'-(paddingHeight*2) + betweenPadding = (betweenPaddingPercent layout) `percentOf` innerRectWidth + outerHueBoxWidth = (hueBoxWidthPercentage layout) `percentOf` innerRectWidth + hueBoxWidth = outerHueBoxWidth - (truncate (hueBoxHandleRadius layout*2.0)) + hueBoxHeight = innerRectHeight-gaugeHeight + sliderWidth = (sliderWidthPercentage layout) `percentOf` innerRectWidth + innerRect = (x'+paddingWidth,y'+paddingHeight,innerRectWidth,innerRectHeight) + previewPaneWidth = (previewPanePercentage layout) `percentOf` innerRectWidth + in + ColorChooserComponentBounds + { + colorChooserSliderBounds = + toRectangle (x'+paddingWidth+outerHueBoxWidth,y'+paddingHeight,sliderWidth,innerRectHeight) + , colorChooserHueBoxBounds = + toRectangle (x'+paddingWidth,y'+paddingHeight,outerHueBoxWidth,innerRectHeight) + , colorChooserPreviewPaneBounds = + toRectangle (x'+paddingWidth+outerHueBoxWidth+sliderWidth+betweenPadding, y'+(if (gaugeStart > paddingHeight) then gaugeStart else paddingHeight), previewPaneWidth, innerRectHeight) + } + +-- | From (hue,saturation) and the size of the hue box calculate corresponding position in the hue box. +fromHs :: (Double,Double) -> PreciseSize -> PrecisePosition +fromHs (hue,saturation) (PreciseSize (PreciseWidth w) (PreciseHeight h)) = + let x = hue/6.0*w + y = (1.0-saturation)*h + in + (PrecisePosition + (PreciseX (if (x<0) then 0.0 else if (x>w) then w else x)) + (PreciseY (if (y<0) then 0.0 else if (y>h) then h else y))) + +-- | Calculate the (hue,saturation) from a point in the hue box +toHs :: PrecisePosition -> (Double,Double) +toHs (PrecisePosition (PreciseX x) (PreciseY y)) = + let h = 6.0*x `mod'` 6.0 + s = 1.0 - y + in + ( + if (h < 0.0) + then 0.0 + else h + , + if (s < 0.0) + then 0.0 + else + if (s > 1.0) + then 1.0 + else s + ) + +-- | Generate the hue box image +generateImage :: Size -> IO (Ref LowLevel.RGBImage) +generateImage size@(Size (Width w') (Height h')) = + let toRgb :: Double -> CUChar + toRgb v = toEnum (truncate (255*v+0.5)) + in do + m <- DVSM.replicate (w'*h'*3) ((toEnum 0) :: CUChar) + mapM_ (\r -> + let yIncrement :: Double + yIncrement = (fromIntegral r / (fromIntegral h')) + in + mapM_ + (\i -> + let offset = (w'*r+i)*3 + xIncrement :: Double + xIncrement = ((fromIntegral i) / (fromIntegral w')) + (h,s) = toHs (PrecisePosition (PreciseX xIncrement) (PreciseY yIncrement)) + in do + rgbM <- LowLevel.hsv2Rgb (Between0And6 h, Between0And1 s, Between0And1 1.0) + case rgbM of + Nothing -> throwIO (userError (Printf.printf "Could not convert hsv (%d,%d,%d) to rgb." h s (1.0 :: Double))) + Just (Between0And1 r, Between0And1 g, Between0And1 b) -> do + DVSM.write m offset (toRgb r) + DVSM.write m (offset+1) (toRgb g) + DVSM.write m (offset+2) (toRgb b) + ) + [0 .. w'-1]) + [0 .. h'-1] + im <- DVS.unsafeFreeze m + LowLevel.rgbImageNew im size Nothing Nothing + +-- | Generate the background of the saturation slider +generateVImage :: RGB -> Size -> IO (Ref LowLevel.SVGImage) +generateVImage (r',g',b') size@(Size (Width w') (Height h')) = + let svgString :: String + svgString = + "\n" ++ + "\n" ++ + "\n" ++ + "\n" ++ + "\n" ++ + "\n" ++ + "\n" ++ + "\n" ++ + "" + in do + iE <- LowLevel.svgImageNew (BChar.pack svgString) + case iE of + Left _ -> throwIO (userError ("generateVImage': the generated SVG is invalid: \n" ++ svgString)) + Right i -> return i + +-- | Handle all events inside the hue box given the 'Double' indicator radius and the 'Int' gauge height. +handleHueBox :: Double -> Int -> Ref LowLevel.ColorChooser -> Ref LowLevel.Box -> Event -> IO (Either UnknownEvent ()) +handleHueBox handleRadius gaugeHeight c b e = do + rect <- LowLevel.getRectangle b + (Right (Between0And6 currH)) <- LowLevel.getHue c + (Right (Between0And1 currS)) <- LowLevel.getSaturation c + (Right (Between0And1 v)) <- LowLevel.getValue c + let focusMe = do + vf <- FL.visibleFocus + when vf (LowLevel.redraw b) + hueBoxRect = hueBoxBounds rect handleRadius gaugeHeight + updateHsv = + let (x',y',w',h') = fromRectangle hueBoxRect + in do + vf <- FL.visibleFocus + when vf ((FL.setFocus b) >> LowLevel.redraw b) + eventPos@(Position (X ex)(Y ey)) <- FL.eventPosition + let xDiff = ex-x' + xIncrement = + if (xDiff <= 0) then 0.0 + else + fromIntegral (if (xDiff > w'-1) then w'-1 else xDiff) / fromIntegral w' + yIncrement = fromIntegral (ey-y') / fromIntegral h' + (h,s) = toHs (PrecisePosition (PreciseX xIncrement) (PreciseY yIncrement)) + ctrlPressed <- FL.containsEventState Kb_CtrlState + r <- LowLevel.setHsv c + ( + Between0And6 (if ctrlPressed then currH else h) + , Between0And1 s + , Between0And1 v + ) + case r of + Left NoChange -> return () + Right _ -> LowLevel.doCallback c + case e of + Push -> updateHsv >> return (Right ()) + Drag -> updateHsv >> return (Right ()) + Focus -> focusMe >> return (Right ()) + Unfocus -> focusMe >> return (Right ()) + Keydown -> + let (PrecisePosition (PreciseX x) (PreciseY y)) = fromHs (currH,currS) (toPreciseSize (rectangleSize rect)) + in do + key <- FL.eventKey + let newXY = case key of + SpecialKeyType Kb_Up -> Just (x,y-3) + SpecialKeyType Kb_Down -> Just (x,y+3) + SpecialKeyType Kb_Left -> Just (x-3,y) + SpecialKeyType Kb_Right -> Just (x+3,y) + _ -> Nothing + case newXY of + Nothing -> return (Left UnknownEvent) + Just (newX,newY) -> + let (_,_,w',h') = fromRectangle hueBoxRect + (h,s) = toHs (PrecisePosition (PreciseX (newX/(fromIntegral w'))) (PreciseY (newY/(fromIntegral h')))) + in do + r <- LowLevel.setHsv c (Between0And6 h, Between0And1 s, Between0And1 v) + case r of + Left NoChange -> return () + Right _ -> LowLevel.doCallback c + return (Right ()) + _ -> return (Left UnknownEvent) + +-- | Draw the saturation slider using the current color to fill in the background image +drawSaturationSlider :: IORef ColorChooserState -> Ref LowLevel.Slider -> IO () +drawSaturationSlider stateRef s = do + bounds <- LowLevel.getRectangle s + state <- readIORef stateRef + damages <- LowLevel.getDamage s + let gaugeImageBounds = gaugeImageRectangle mkGaugeSliderSpec bounds + when True -- (DamageExpose `elem` damages) + (do + c <- LowLevel.getColor s + LowLevel.flcRectfWithColor gaugeImageBounds c + rgbM <- LowLevel.hsv2Rgb (colorChooserHue state, colorChooserSaturation state, Between0And1 1.0) + maybe (return ()) + (\rgb -> do + i <- generateVImage (extractRgb rgb) (rectangleSize gaugeImageBounds) + LowLevel.draw i (rectanglePosition gaugeImageBounds) + LowLevel.destroy i) + rgbM) + when ((DamageAll `elem` damages) || (DamageExpose `elem` damages)) + (drawSlider s (Just mkGaugeSliderSpec) bounds) + +-- | Calculate the bounds of the saturation slider +gaugeImageRectangle :: GaugeSliderSpec -> Rectangle -> Rectangle +gaugeImageRectangle spec bounds = + let (gX,gY,gW,gH) = fromRectangle (gaugeBoxBounds False spec bounds) + imageSize = Size (Width (gW-2)) (Height (gH-2)) + imagePosition = (Position (X (gX+1)) (Y (gY+1))) + in (Rectangle imagePosition imageSize) + +extractRgb :: (Between0And1, Between0And1, Between0And1) -> RGB +extractRgb (Between0And1 _r, Between0And1 _g, Between0And1 _b) = (truncate (_r*255.0), truncate (_g*255.0), truncate (_b*255.0)) + +-- | Update all the controls based on the dial selected HSV +updateHsv :: IORef ColorChooserState -> Ref LowLevel.Slider -> Ref LowLevel.Box -> Ref LowLevel.FillDial -> Ref LowLevel.FillDial -> Ref LowLevel.FillDial -> Ref LowLevel.Group -> Ref LowLevel.ColorChooser -> (Between0And6, Between0And1, Between0And1) -> IO Int +updateHsv stateRef slider hueBox rInput gInput bInput previewGroup colorChooser (Between0And6 _h, Between0And1 _s, Between0And1 _v) = + let h = + let __h = _h `mod'` 6.0 + in if (__h<0) then __h+6.0 else __h + s = + if (_s<0) then 0.0 else if (_s>1.0) then 1.0 else _s + v = + if (_v<0) then 0.0 else if (_v>1.0) then 1.0 else _v + in do + state <- readIORef stateRef + let (Between0And6 currH) = colorChooserHue state + (Between0And1 currS) = colorChooserSaturation state + (Between0And1 currV) = colorChooserValue state + changed :: Int + changed = runST (do + ref <- newSTRef 0 + when (h /= currH) (writeSTRef ref 1) + when (s /= currS) (writeSTRef ref 1) + when (v /= currV) (writeSTRef ref 1) + readSTRef ref) + when (h /= currH) + (do + LowLevel.setDamage hueBox [DamageScroll] + LowLevel.setDamage slider [DamageExpose] + LowLevel.setDamage previewGroup [DamageExpose] + ds <- LowLevel.getDamage slider + modifyIORef stateRef (\state -> state { colorChooserHue = Between0And6 h })) + when (s /= currS) + (do + LowLevel.setDamage hueBox [DamageScroll] + LowLevel.setDamage slider [DamageExpose] + LowLevel.setDamage previewGroup [DamageExpose] + modifyIORef stateRef (\state -> state { colorChooserSaturation = Between0And1 s })) + when (v /= currV) + (do + LowLevel.setValue slider (1-v) + LowLevel.setDamage previewGroup [DamageExpose] + modifyIORef stateRef (\state -> state { colorChooserValue = Between0And1 v })) + when (changed == 1) + (do + rgb <- LowLevel.hsv2Rgb (Between0And6 h, Between0And1 s, Between0And1 v) + LowLevel.setChanged colorChooser + case rgb of + Just (r,g,b) -> modifyIORef stateRef (\s -> s { colorChooserR = r, colorChooserG = g, colorChooserB = b }) + Nothing -> return () + setValuators rInput gInput bInput colorChooser) + setValuators rInput gInput bInput colorChooser + return changed + +-- | Update all the controls based on the dial selected RGB value +updateRgb :: IORef ColorChooserState -> Ref LowLevel.Slider -> Ref LowLevel.Box -> Ref LowLevel.FillDial -> Ref LowLevel.FillDial -> Ref LowLevel.FillDial -> Ref LowLevel.Group -> Ref LowLevel.ColorChooser -> (Between0And1, Between0And1, Between0And1) -> IO Int +updateRgb stateRef slider hueBox rValue gValue bValue previewGroup c rgb@(Between0And1 r, Between0And1 g, Between0And1 b) = do + state <- readIORef stateRef + let (Between0And1 currR) = colorChooserR state + (Between0And1 currG) = colorChooserG state + (Between0And1 currB) = colorChooserB state + changed = runST (do + ref <- newSTRef 0 + when (r /= currR) (writeSTRef ref 1) + when (g /= currG) (writeSTRef ref 1) + when (b /= currB) (writeSTRef ref 1) + readSTRef ref) + when (r /= currR) + (do + LowLevel.setDamage hueBox [DamageScroll] + LowLevel.setDamage slider [DamageExpose] + LowLevel.setDamage previewGroup [DamageExpose] + modifyIORef stateRef (\state -> state { colorChooserR = Between0And1 r })) + when (g /= currG) + (do + LowLevel.setDamage hueBox [DamageScroll] + LowLevel.setDamage slider [DamageExpose] + LowLevel.setDamage previewGroup [DamageExpose] + modifyIORef stateRef (\state -> state { colorChooserG = Between0And1 g })) + when (b /= currB) + (do + LowLevel.setDamage hueBox [DamageScroll] + LowLevel.setDamage slider [DamageExpose] + LowLevel.setDamage previewGroup [DamageExpose] + modifyIORef stateRef (\state -> state { colorChooserB = Between0And1 b })) + when (changed == 1) + (do + rgb <- LowLevel.rgb2Hsv rgb + LowLevel.setChanged c + case rgb of + Just (h,s,v) -> modifyIORef stateRef (\state -> state { colorChooserHue = h, colorChooserSaturation = s, colorChooserValue = v }) + Nothing -> return ()) + setValuators rValue gValue bValue c + return changed + +-- | Update the dials if the preview mode is changed from RGB->Hex->HSV->Byte mode +modeMenuCallback :: IORef ColorChooserState -> Ref LowLevel.FillDial -> Ref LowLevel.FillDial -> Ref LowLevel.FillDial -> Ref LowLevel.ColorChooser -> Ref LowLevel.Choice -> IO () +modeMenuCallback stateRef rValue gValue bValue chooser choice = do + (AtIndex i) <- LowLevel.getValue choice + case i of + 0 -> modifyIORef stateRef (\state -> state { colorChooserMode = RgbMode }) + 1 -> modifyIORef stateRef (\state -> state { colorChooserMode = ByteMode }) + 2 -> modifyIORef stateRef (\state -> state { colorChooserMode = HexMode }) + 3 -> modifyIORef stateRef (\state -> state { colorChooserMode = HsvMode }) + _ -> throwIO (userError "modeMenuCallback: Only RGB, Byte, Hex and Hsv are valid modes.") + setValuators rValue gValue bValue chooser + +-- | React to changes the dials in the preview pane +colorDialCallback :: Ref LowLevel.FillDial -> Ref LowLevel.FillDial -> Ref LowLevel.FillDial -> Ref LowLevel.ColorChooser -> IO () +colorDialCallback rValue gValue bValue c = do + rV <- LowLevel.getValue rValue + gV <- LowLevel.getValue gValue + bV <- LowLevel.getValue bValue + m <- LowLevel.getMode c + case m of + HsvMode -> LowLevel.setHsv c (Between0And6 rV, Between0And1 gV, Between0And1 bV) + _ -> LowLevel.setRgb c (Between0And1 rV, Between0And1 gV, Between0And1 bV) + LowLevel.doCallback c + +-- | React to changes in the saturation slider +sliderCallback :: IORef ColorChooserState -> Ref LowLevel.ColorChooser -> Ref LowLevel.Slider -> IO () +sliderCallback stateRef c slider = do + state <- readIORef stateRef + v <- LowLevel.getValue slider + LowLevel.setHsv c (colorChooserHue state, colorChooserSaturation state, Between0And1 (1.0-v)) + LowLevel.doCallback c + +-- | Set the dials according the selected color +setValuators :: Ref LowLevel.FillDial -> Ref LowLevel.FillDial -> Ref LowLevel.FillDial -> Ref LowLevel.ColorChooser -> IO () +setValuators rInput gInput bInput c = do + let toThreeDecimals v = fromIntegral (truncate (v*1000)) / 1000 + m <- LowLevel.getMode c + case m of + RgbMode -> do + rgbE <- LowLevel.getRgb c + case rgbE of + Left _ -> return () + Right (Between0And1 r, Between0And1 g, Between0And1 b) -> do + mapM_ (\i -> do + LowLevel.range i 0 1 + LowLevel.setStep i (1%1000) + LowLevel.precision i 3) + [rInput,gInput,bInput] + LowLevel.setValue rInput r + LowLevel.setValue gInput g + LowLevel.setValue bInput b + LowLevel.setSelectionColor rInput redColor + LowLevel.setSelectionColor gInput greenColor + LowLevel.setSelectionColor bInput blueColor + LowLevel.setLabel rInput (T.pack (show (toThreeDecimals r))) + LowLevel.setLabel gInput (T.pack (show (toThreeDecimals g))) + LowLevel.setLabel bInput (T.pack (show (toThreeDecimals b))) + return () + HsvMode -> do + hsvE <- LowLevel.getHsv c + case hsvE of + Left _ -> return () + Right (Between0And6 h, Between0And1 s, Between0And1 v) -> do + LowLevel.range rInput 0 6 + LowLevel.setStep rInput (1%1000) + mapM_ (\i -> do + LowLevel.range i 0 1 + LowLevel.setStep i (1%1000)) + [gInput,bInput] + LowLevel.setValue rInput h + LowLevel.setValue gInput s + LowLevel.setValue bInput v + color <- commonFillColor + LowLevel.setSelectionColor rInput color + LowLevel.setSelectionColor gInput color + LowLevel.setSelectionColor bInput color + LowLevel.setLabel rInput (T.pack (show (toThreeDecimals h))) + LowLevel.setLabel gInput (T.pack (show (toThreeDecimals s))) + LowLevel.setLabel bInput (T.pack (show (toThreeDecimals v))) + return () + HexMode -> do + rgbE <- LowLevel.getRgb c + case rgbE of + Left _ -> return () + Right (Between0And1 r, Between0And1 g, Between0And1 b) -> do + mapM_ (\i -> do + LowLevel.range i 0 1 + LowLevel.setStep i 1 + LowLevel.precision i 3) + [rInput,gInput,bInput] + LowLevel.setValue rInput r + LowLevel.setValue gInput g + LowLevel.setValue bInput b + LowLevel.setSelectionColor rInput redColor + LowLevel.setSelectionColor gInput greenColor + LowLevel.setSelectionColor bInput blueColor + LowLevel.setLabel rInput (T.pack ("0x" ++ (showHex (truncate (255*r+0.5)) ""))) + LowLevel.setLabel gInput (T.pack ("0x" ++ (showHex (truncate (255*g+0.5)) ""))) + LowLevel.setLabel bInput (T.pack ("0x" ++ (showHex (truncate (255*b+0.5)) ""))) + return () + ByteMode -> do + rgbE <- LowLevel.getRgb c + case rgbE of + Left _ -> return () + Right (Between0And1 r, Between0And1 g, Between0And1 b) -> do + mapM_ (\i -> do + LowLevel.range i 0 1 + LowLevel.setStep i 1 + LowLevel.precision i 3) + [rInput,gInput,bInput] + LowLevel.setValue rInput r + LowLevel.setValue gInput g + LowLevel.setValue bInput b + LowLevel.setSelectionColor rInput redColor + LowLevel.setSelectionColor gInput greenColor + LowLevel.setSelectionColor bInput blueColor + LowLevel.setLabel rInput (T.pack (show (truncate (255*r+0.5)))) + LowLevel.setLabel gInput (T.pack (show (truncate (255*g+0.5)))) + LowLevel.setLabel bInput (T.pack (show (truncate (255*b+0.5)))) + return () + LowLevel.getParent rInput >>= maybe (return ()) LowLevel.redrawLabel + +fillBoxWithColor :: Ref LowLevel.Box -> Color -> IO () +fillBoxWithColor b color = do + bounds <- LowLevel.getRectangle b + let slightlyDarker = Enumerations.colorAverage color blackColor 0.80 + let spec = + BorderBoxSpec + { + borderBoxHoveringColor = slightlyDarker + , borderBoxColor = slightlyDarker + , borderBoxFocusedColor = slightlyDarker + , borderBoxFillColor = color + , borderBoxBounds = bounds + } + drawBorderBox b spec True + +drawPreviewColor :: Ref LowLevel.ColorChooser -> Ref LowLevel.Box -> IO () +drawPreviewColor c b = do + rgbE <- LowLevel.getRgb c + either + (\_ -> return ()) + (\rgb -> do + color <- rgbColorWithRgb (extractRgb rgb) + fillBoxWithColor b color) + rgbE + +drawCurrentColor :: Color -> Ref LowLevel.Box -> IO () +drawCurrentColor c b = fillBoxWithColor b c + +drawColorDials :: (?assets :: Assets) => Ref LowLevel.ColorChooser -> IORef ColorChooserState -> Rectangle -> Maybe Color -> IO (Ref LowLevel.FillDial,Ref LowLevel.FillDial,Ref LowLevel.FillDial,Ref LowLevel.Group) +drawColorDials c stateRef rect initialColor = + let modeMenuHeight = 20 + colorDialHeight = 40 + modeMenuPadding = 3 + (x',y',w',h') = fromRectangle rect + dialSize = Size (Width colorDialHeight) (Height colorDialHeight) + in do + modeMenu <- choiceNew (toRectangle (x',y',w',modeMenuHeight)) Nothing + rgbI <- LowLevel.add modeMenu "RGB" Nothing (Nothing :: Maybe (Ref LowLevel.MenuItem -> IO ())) (MenuItemFlags []) + _ <- LowLevel.add modeMenu "Byte" Nothing (Nothing :: Maybe (Ref LowLevel.MenuItem -> IO ())) (MenuItemFlags []) + _ <- LowLevel.add modeMenu "Hex" Nothing (Nothing :: Maybe (Ref LowLevel.MenuItem -> IO ())) (MenuItemFlags []) + _ <- LowLevel.add modeMenu "HSV" Nothing (Nothing :: Maybe (Ref LowLevel.MenuItem -> IO ())) (MenuItemFlags []) + _ <- LowLevel.setValue modeMenu (LowLevel.MenuItemByIndex rgbI) + let colorDialGroupY = y'+modeMenuHeight+modeMenuPadding + colorDialGroupH = 3*colorDialHeight + colorDialGroup <- groupNew (toRectangle (x',colorDialGroupY,w',colorDialGroupH)) Nothing + LowLevel.begin colorDialGroup + let rValuePosition = Position (X x') (Y (y'+modeMenuHeight+modeMenuPadding)) + gValuePosition = Position (X x') (Y (y'+modeMenuHeight+modeMenuPadding+colorDialHeight)) + bValuePosition = Position (X x') (Y (y'+modeMenuHeight+modeMenuPadding+(2*colorDialHeight))) + rValue <- fillDialNew (Rectangle rValuePosition dialSize) Nothing + gValue <- fillDialNew (Rectangle gValuePosition dialSize) Nothing + bValue <- fillDialNew (Rectangle bValuePosition dialSize) Nothing + mapM_ (\w -> do + LowLevel.setAlign w (Alignments [AlignTypeRight]) + LowLevel.setCallback w (\_ -> colorDialCallback rValue gValue bValue c)) + [rValue,gValue,bValue] + LowLevel.end colorDialGroup + previewGroup <- groupNew (toRectangle (x',colorDialGroupY+colorDialGroupH,w',colorDialGroupY-y')) Nothing + let previewBoxHeight = 20 -- (h'-colorDialGroupH-modeMenuHeight-modeMenuPadding) `intDiv` 2 + LowLevel.begin previewGroup + LowLevel.boxCustom (toRectangle (x',colorDialGroupY+colorDialGroupH+modeMenuPadding,w',previewBoxHeight-modeMenuPadding)) Nothing + (Just (drawPreviewColor c)) + Nothing + case initialColor of + Just initialColor' -> do + LowLevel.boxCustom (toRectangle (x',colorDialGroupY+colorDialGroupH+modeMenuPadding+previewBoxHeight,w',previewBoxHeight-modeMenuPadding)) Nothing + (Just (drawCurrentColor initialColor')) + Nothing + return () + Nothing -> return () + LowLevel.end previewGroup + LowLevel.setResizable previewGroup (Nothing :: Maybe (Ref LowLevel.Widget)) + LowLevel.setCallback modeMenu (modeMenuCallback stateRef rValue gValue bValue c) + return (rValue, gValue, bValue,previewGroup) + +colorChooserNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> Maybe Color -> IO (Ref LowLevel.ColorChooser) +colorChooserNew rect l' initialColor = + let layout = makeColorChooserComponentLayout (rectangleSize rect) maxSliderWidth defaultGaugeHeight + componentBounds = makeColorChooserComponentBounds layout rect defaultGaugeHeight + in mdo + let initialState = + ColorChooserState + { + colorChooserR = Between0And1 1.0 + , colorChooserG = Between0And1 1.0 + , colorChooserB = Between0And1 1.0 + , colorChooserHue = Between0And6 0.0 + , colorChooserSaturation = Between0And1 0.0 + , colorChooserValue = Between0And1 1.0 + , colorChooserHueImage = hueImage + , colorChooserMode = RgbMode + } + stateRef <- newIORef initialState + c <- LowLevel.colorChooserCustom rect l' Nothing + (Just + (LowLevel.CustomColorChooserFuncs + { + LowLevel.getModeCustom = \_ -> fmap colorChooserMode (readIORef stateRef) + , LowLevel.setModeCustom = \_ m -> modifyIORef stateRef (\state -> state { colorChooserMode = m }) + , LowLevel.hueCustom = \_ -> fmap colorChooserHue (readIORef stateRef) + , LowLevel.saturationCustom = \_ -> fmap colorChooserSaturation (readIORef stateRef) + , LowLevel.valueCustom = \_ -> fmap colorChooserValue (readIORef stateRef) + , LowLevel.rCustom = \_ -> fmap colorChooserR (readIORef stateRef) + , LowLevel.gCustom = \_ -> fmap colorChooserG (readIORef stateRef) + , LowLevel.bCustom = \_ -> fmap colorChooserB (readIORef stateRef) + , LowLevel.hsvCustom = updateHsv stateRef g b rValue gValue bValue previewGroup + , LowLevel.rgbCustom = updateRgb stateRef g b rValue gValue bValue previewGroup + })) + Nothing + cs <- LowLevel.getArray c + mapM_ LowLevel.hide cs + numChildren <- LowLevel.children c + mapM_ (LowLevel.removeIndex c . AtIndex) [0 .. numChildren-1] + let color = lightBackground + LowLevel.setColor c color + LowLevel.begin c + hueImage <- generateImage (rectangleSize (colorChooserHueBoxBounds componentBounds)) + b <- LowLevel.boxCustom (colorChooserHueBoxBounds componentBounds) Nothing + (Just (drawHueBox (hueBoxHandleRadius layout) defaultGaugeHeight stateRef c)) + (Just (LowLevel.defaultCustomWidgetFuncs {LowLevel.handleCustom = (Just (handleHueBox (hueBoxHandleRadius layout) defaultGaugeHeight c))})) + g <- LowLevel.sliderCustom + (colorChooserSliderBounds componentBounds) + Nothing + (Just (drawSaturationSlider stateRef)) + (Just (LowLevel.defaultCustomWidgetFuncs {LowLevel.handleCustom = Just handleHover})) + sliderSetup g + LowLevel.setCallback g (sliderCallback stateRef c) + let (paneX, paneY, paneW, paneH) = fromRectangle (colorChooserPreviewPaneBounds componentBounds) + (Rectangle (Position _ (Y hueBoxY)) (Size _ (Height hueBoxHeight))) = hueBoxBounds (colorChooserHueBoxBounds componentBounds)(hueBoxHandleRadius layout) defaultGaugeHeight + rgbE <- LowLevel.getRgb c + let previewPaneDialBounds = toRectangle (paneX,hueBoxY,paneW,hueBoxHeight) + previewPaneDialGroup <- groupNew previewPaneDialBounds Nothing + LowLevel.begin previewPaneDialGroup + (rValue,gValue,bValue,previewGroup) <- drawColorDials c stateRef (toRectangle (paneX,hueBoxY,paneW,hueBoxHeight)) initialColor + LowLevel.end previewPaneDialGroup + LowLevel.setResizable previewPaneDialGroup (Nothing :: (Maybe (Ref LowLevel.Widget))) + either + (\_ -> return ()) + (\rgb@(Between0And1 r,Between0And1 g,Between0And1 b) -> do + LowLevel.setValue rValue r + LowLevel.setValue gValue g + LowLevel.setValue bValue b + setValuators rValue gValue bValue c + return ()) + rgbE + LowLevel.end c + LowLevel.setResizable c (Just b) + LowLevel.setColor c color + LowLevel.setBox c BorderBox + LowLevel.setLabelfont c commonFont + LowLevel.setLabelsize c commonFontSize + commonSelectionColor >>= LowLevel.setSelectionColor c + return c + +flcColorChooser :: (?assets :: Assets) => Maybe T.Text -> Maybe Rectangle -> Maybe Color -> Maybe ColorChooserMode -> IO (Maybe Color) +flcColorChooser name rectM initialColor mode = + let buttonBarHeight = 50 + colorChooserPadding = 5 + windowBounds = maybe ((Rectangle (Position (X 215) (Y 200)) (Size (Width 400) (Height (200 + buttonBarHeight))))) id rectM + colorChooserBounds = + let (x',y',w',h') = fromRectangle windowBounds + in toRectangle(colorChooserPadding,0,w'-(colorChooserPadding*2),h'-buttonBarHeight) + buttonBarBounds = + let (x',y',w',h') = fromRectangle windowBounds + in toRectangle (colorChooserPadding,h'-buttonBarHeight,w'-(colorChooserPadding*2),buttonBarHeight) + buttonWidth = 65 + buttonHeight = 30 + cancelButtonBounds = + let (buttonGroupX, buttonGroupY, buttonGroupW, buttonGroupH) = fromRectangle buttonBarBounds + in toRectangle (buttonGroupX+buttonGroupW-buttonWidth, buttonGroupY+((buttonGroupH-buttonHeight) `intDiv` 2),buttonWidth,buttonHeight) + okButtonBounds = + let (buttonGroupX, buttonGroupY, buttonGroupW, buttonGroupH) = fromRectangle buttonBarBounds + in toRectangle (buttonGroupX+buttonGroupW-buttonWidth-5-buttonWidth,buttonGroupY+((buttonGroupH-buttonHeight) `intDiv` 2),buttonWidth,buttonHeight) + showUntilHidden w = do + isShown <- LowLevel.shown w + if isShown then FL.wait >> showUntilHidden w + else return () + buttonCallback :: IORef Bool -> Ref LowLevel.DoubleWindow -> Bool -> Ref LowLevel.Button -> IO () + buttonCallback selectedRef w v _ = do + LowLevel.hide w + writeIORef selectedRef v + in do + okSelectedRef <- newIORef False + window <- doubleWindowNew (rectangleSize windowBounds) (Just (rectanglePosition windowBounds)) name + LowLevel.begin window + cc <- colorChooserNew colorChooserBounds Nothing initialColor + buttonGroup <- groupNew buttonBarBounds Nothing + LowLevel.begin buttonGroup + okButton <- okButtonNew okButtonBounds + cancelButton <- cancelButtonNew cancelButtonBounds + LowLevel.setCallback okButton (buttonCallback okSelectedRef window True) + LowLevel.setCallback cancelButton (buttonCallback okSelectedRef window False) + LowLevel.end buttonGroup + LowLevel.end window + LowLevel.setModal window + LowLevel.hotSpot window (LowLevel.ByWidget window) Nothing + LowLevel.setResizable window (Just cc) + LowLevel.showWidget window + showUntilHidden window + okSelected <- readIORef okSelectedRef + if okSelected + then do + rgb <- LowLevel.getRgb cc + case rgb of + Left OutOfRange -> throwIO (userError "flcColorChooser: RGB value selected is out of range.") + Right rgb' -> rgbColorWithRgb (extractRgb rgb') >>= return . Just + else return initialColor diff --git a/src/Graphics/UI/FLTK/Theme/Light/Common.hs b/src/Graphics/UI/FLTK/Theme/Light/Common.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/FLTK/Theme/Light/Common.hs @@ -0,0 +1,497 @@ +{-# LANGUAGE ImplicitParams, OverloadedStrings, AllowAmbiguousTypes, GADTs, CPP, ExistentialQuantification, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, ScopedTypeVariables, UndecidableInstances #-} +module Graphics.UI.FLTK.Theme.Light.Common + ( + -- * Theme Loading + configureTheme, + -- * Common Colors & Fonts + commonColor, + commonDarkGreyColor, + commonFillColor, + commonFont, + commonFontSize, + commonLargeFontSize, + commonSelectionColor, + lightBackground, + -- * Common Calculations For Drawing Widgets + angleToCoordinate, + centerInRectangle, + centerInRectangleByRelativePosition, + degreesPerRadian, + fromFltkAngle, + insideRectangle, + intDiv, + isWidget, + percentOf, + percentOfSmallerEllipseRadius, + positionInside, + splitVertically, + splitVerticallyByPixels, + splitHorizontally, + splitHorizontallyByPixels, + withPositionX, + withPositionY, + withSizeHeight, + withSizeWidth, + -- * Common Widget Drawing Helpers + withCustomBoxDraw, + BorderBoxSpec(..), + drawBorderBox, + FillSpec(..), + makeFillSpec, + borderRectangle, + fillRectangle, + handleHover, + OpenBorder(..), + roundedBoxPoints + ) +where +import Control.Monad +import Graphics.UI.FLTK.LowLevel.Dispatch +import Graphics.UI.FLTK.LowLevel.FLTKHS hiding (colorAverage, isHorizontal, inactive, tabPositionsCustom, tabHeightCustom, tabDrawCustom, find, tabWhichCustom, tabRedrawTabs) +import Graphics.UI.FLTK.LowLevel.Fl_Enumerations +import Graphics.UI.FLTK.Theme.Light.Assets +import qualified Graphics.UI.FLTK.LowLevel.FL as FL + +-- | For drawing a rectangular widget that is borderless on the top or bottom. Guess +-- it could be passed into a function as yet another Bool but we have too many of those +-- as it is. +data OpenBorder = + OpenBorderTop -- ^ Signifies a bordered rectangle with the top side. Useful, for example, for a bottom tab + | OpenBorderBottom -- ^ Signifies a bordered rectangle without a bottom side. Useful, for example, for a top tab + +-- | Specifies how to draw a border around a 'Rectangle'. +data BorderBoxSpec = + BorderBoxSpec + { + borderBoxBounds :: Rectangle, -- ^ The bounds of the rectangle to border + borderBoxFocusedColor :: Color, -- ^ The color of the border if the widget is focused + borderBoxHoveringColor :: Color, -- ^ The color of the border if the mouse pointer is over the widget + borderBoxColor :: Color, -- ^ The default color of the border + borderBoxFillColor :: Color -- ^ The fill color of the rectangle. Even though 'FillSpec' exists this is useful if you want a simple solid color and don't care about gradients. + } deriving Show + + +-- | Specifies how a 'Rectangle' should be filled. Allows for a vertical color gradient. +data FillSpec = + FillSpec + { + fillBounds :: Rectangle -- ^ The bounds of the rectangle to be filled + , fillTopColor :: Color -- ^ The color at the top of the rectangle + , fillTopSelectionColor :: Color -- ^ The color at the top of the rectangle if this widget is selected (mostly of use to buttons) + , fillTopFillPercentage :: Int -- ^ The % of the rectangle at that top that is filled with 'fillTopColor' before the gradient begins + , fillBottomColor :: Color -- ^ The color at the bottom of the rectangle + , fillBottomSelectionColor :: Color -- ^ The color at the bottom of the rectangle if this widget is selected (mostly of use to buttons) + , fillBottomFillPercentage :: Int -- ^ The % of the rectangle at the bottom that is filled with 'fillBottomColor' after the gradient ends + , fillCornerRadius :: Int -- ^ The roundedness of the corners + , fillBorderColor :: Color -- ^ The border color of this rectangle + , fillBorderFocusColor :: Color -- ^ The border color of this rectangle if it is focused + , fillBorderHovered :: Color -- ^ The border color of this rectangle if the mouse is over it + } + +commonFont :: (?assets :: Assets) => Font +commonFont = dejaVuSans + +commonFontSize :: FontSize +commonFontSize = FontSize 12 + +commonLargeFontSize :: FontSize +commonLargeFontSize = FontSize 22 + +commonColor :: IO Color +commonColor = rgbColorWithRgb (0xF9, 0xF9, 0xF9) + +commonDarkGreyColor :: IO Color +commonDarkGreyColor = rgbColorWithRgb (80,81,84) + +commonFillColor :: IO Color +commonFillColor = rgbColorWithRgb (0x66, 0x94, 0xE3) + +lightBackground :: Color +lightBackground = whiteColor + +-- | Converts from an FLTK angle to a unit circle's. FLTK starts its angles counter-clockwise +-- from 270 so, for example, 45 degrees in FLTK is 270-45 = 225 degrees on a unit circle. +-- Angle unit is in degrees. +fromFltkAngle :: PreciseAngle -> PreciseAngle +fromFltkAngle (PreciseAngle a) = + let unitCircleAngle = (270 - (truncate a)) `mod` 360 + in + PreciseAngle + (if (unitCircleAngle < 0) + then 360.0 - (abs (fromIntegral unitCircleAngle)) + else (fromIntegral unitCircleAngle)) + +-- | pi/180 +degreesPerRadian :: Double +degreesPerRadian = pi/180 + +-- | Given a 'PreciseAngle' /in degrees/ return the corresponding location on the unit circle +angleToCoordinate :: PreciseAngle -> PrecisePosition +angleToCoordinate (PreciseAngle a) = + case a of + _ | a == 360 -> PrecisePosition (PreciseX (cos 0)) (PreciseY (sin 0)) + | otherwise -> + let radians = a * degreesPerRadian + in PrecisePosition (PreciseX (cos radians)) (PreciseY (sin radians)) + +-- | Straightfoward % of the given 'Int', the 'Double' % must be between 0.0 and 1.0 +percentOf :: Double -> Int -> Int +percentOf p a = truncate ((fromIntegral a) * p) + +-- | Given the width and height of an ellipse via 'PreciseSize', return +-- the 'Double' % of the smaller radius. % must be between 0.0 and 1.0. +-- Used in 'Dial's and 'Clock's to measure the length of hands. +percentOfSmallerEllipseRadius :: Double -> PreciseSize -> Double +percentOfSmallerEllipseRadius percent (PreciseSize (PreciseWidth rW) (PreciseHeight rH)) = ((if (rW < rH) then rW else rH) * percent) / 100.0 + +commonSelectionColor :: IO Color +commonSelectionColor = rgbColorWithRgb (50, 100, 201) + +-- | Check if the given references point to the same 'Widget'. +isWidget :: (Parent a Widget) => Ref a -> IO (Maybe (Ref b)) -> IO Bool +isWidget this thatM = thatM >>= maybe (return False) (refPtrEquals this) + +-- | Check if the given 'Position' is inside the 'Rectangle'. Useful for +-- checking if an event happened within some bounds. +insideRectangle :: Position -> Rectangle -> Bool +insideRectangle (Position (X x) (Y y)) rect = + let (rx,ry,rw,rh) = fromRectangle rect + in x >= rx && x <= rx+rw && y >= ry && y <= ry+rh + +-- | Return a set of vertices that circumscribe a region bounded by 'Rectangle'. +-- The 'Maybe' 'Int' when provided means the rectangle has rounded corners of +-- 'Int' radius. In a rounded rectangle the vertices don't meet stopping short +-- of the corners, the client is responsible for filling in the arcs. +-- +-- 'Maybe' 'OpenBorder' determines whether the rectangle is whole (if not +-- provided) or has an open top or bottom. +roundedBoxPoints :: Rectangle -> Maybe Int -> Maybe OpenBorder -> [Position] +roundedBoxPoints (Rectangle (Position (X x) (Y y)) (Size (Width w) (Height h))) maybeRadius maybeOpen = + let insideW = w-1 + insideH = h-1 + in + map toPosition + (case (maybeRadius,maybeOpen) of + (Just radius, Nothing) -> + [ + (x+radius,y) + , (x+insideW-radius,y) + , (x+insideW,y+radius) + , (x+insideW,y+insideH-radius) + , (x+insideW-radius,y+insideH) + , (x+radius,y+insideH) + , (x,y+insideH-radius) + , (x,y+radius) + , (x+radius,y) + ] + (Just radius, Just OpenBorderBottom) -> + [ + (x,y+h) + , (x,y+radius) + , (x+radius,y) + , (x+insideW-radius,y) + , (x+insideW,y+radius) + , (x+insideW,y+h) + ] + (Just radius, Just OpenBorderTop) -> + [ + (x+insideW,y) + , (x+insideW,y+insideH-radius) + , (x+insideW-radius,y+insideH) + , (x+radius,y+insideH) + , (x,y+insideH-radius) + , (x,y) + ] + (Nothing, Just OpenBorderBottom) -> + [ + (x,y+insideH) + , (x,y) + , (x+insideW,y) + , (x+insideW,y+insideH) + ] + (Nothing, Just OpenBorderTop) -> + [ + (x,y) + , (x,y+insideH) + , (x+insideW,y+insideH) + , (x+insideW,y) + ] + (Nothing, Nothing) -> + [ + (x,y) + , (x+insideW,y) + , (x+insideW,y+insideH) + , (x,y+insideH) + , (x,y) + ]) + +-- | Draw a bordered rectangle for the given widget according to 'BorderBoxSpec', the 'Bool' +-- determines if it should be filled with 'borderBoxFillColor'. +drawBorderBox :: (Parent a Widget) => Ref a -> BorderBoxSpec -> Bool -> IO () +drawBorderBox w spec shouldFill = do + oldColor <- flcColor + focused <- isWidget w FL.focus + hovering <- isWidget w FL.belowmouse + when shouldFill (flcRectfWithColor (borderBoxBounds spec) (borderBoxFillColor spec)) + if focused + then flcSetColor (borderBoxFocusedColor spec) + else if hovering + then flcSetColor (borderBoxHoveringColor spec) + else flcSetColor (borderBoxColor spec) + flcBeginLine + mapM_ (flcVertex . toPrecisePosition) (roundedBoxPoints (borderBoxBounds spec) Nothing Nothing) + flcEndLine + flcSetColor oldColor + +-- | The default FLTK widgets don't react to a mouse pointer hovering over them. +-- This handler when applied to a customized widget initiates a 'redraw' when the +-- mouse enters and leaves the widget area. +handleHover :: + ( + Parent orig Widget, + Match x ~ FindOp orig orig (Redraw ()), + Op (Redraw ()) x orig (IO ()), + Match y ~ FindOp orig orig (HandleSuper ()), + Op (HandleSuper ()) y orig (Event -> IO (Either UnknownEvent ())) + ) + => Ref orig -> Event -> IO (Either UnknownEvent ()) +handleHover b e = do + case e of + Enter -> do + () <- redraw b + return (Right()) + Leave -> do + () <- redraw b + return (Right ()) + _ -> handleSuper b e + +-- | Temporarily swap out the FLTK's box drawing function for a given 'Boxtype' +-- with 'BoxDrawF'. The 'IO' '()' action will typically use the custom function +-- that was just swapped in some kind custom drawing routine. For example, if a +-- custom widget used a 'BorderBox' on the FLTK side but you don't like the +-- default 'BorderBox' look, you can override the 'draw' function of the widget +-- with this one where the 'IO' '()' action calls 'drawSuper'. For an example +-- use-case see 'Graphics.UI.FLTK.Theme.Light.Input.inputDraw'. +-- +-- NOTE: The 'IO' '()' action is /not/ exception safe. +withCustomBoxDraw :: Boxtype -> BoxDrawF -> IO () -> IO () +withCustomBoxDraw boxtype customBoxDrawF action = do + fptr <- FL.getBoxtypePrim boxtype + dx <- FL.boxDx boxtype + dy <- FL.boxDy boxtype + dw <- FL.boxDw boxtype + dh <- FL.boxDh boxtype + FL.setBoxtype boxtype (FL.FromSpec customBoxDrawF 0 0 0 0) + action + FL.setBoxtype boxtype (FL.FromFunPtr fptr (fromIntegral dx) (fromIntegral dy) (fromIntegral dw) (fromIntegral dh)) + +-- | Make the default 'FillSpec' used by most of the theme color graded with the initial 'Color'. The second 'Color' +-- is used to determine the border color. +makeFillSpec :: Rectangle -> Color -> Color -> IO FillSpec +makeFillSpec rect color selectionColor = do + (colorR, colorG, colorB) <- FL.getColorRgb color + pressedColor <- rgbColorWithRgb (colorR - 21, colorG - 21, colorB - 21) + let slightlyDarker = colorAverage color blackColor 0.93 + let slightlyLighter = colorAverage whiteColor pressedColor 0.93 + hoverColor <- rgbColorWithRgb (0xBB, 0xBB, 0xBB) + let darkerSelectionColor = darker selectionColor + return + FillSpec + { + fillBounds = rect, + fillTopColor = color, + fillTopSelectionColor = pressedColor, + fillTopFillPercentage = 30, + fillBottomColor = slightlyDarker, + fillBottomSelectionColor = slightlyLighter, + fillBottomFillPercentage = 70, + fillCornerRadius = 2, + fillBorderColor = slightlyDarker, + fillBorderFocusColor = darkerSelectionColor, + fillBorderHovered = hoverColor + } + +-- | Draw the border around the 'Rectangle' specified by 'FillSpec' possibly changing the border color +-- if the widget (usually a Button) is currently focused or if the mouse pointer is hovering over it. +borderRectangle :: FillSpec -> Bool -> Bool -> IO () +borderRectangle spec focused hovering = do + oldColor <- flcColor + if focused + then flcSetColor (fillBorderFocusColor spec) + else if hovering + then flcSetColor (fillBorderHovered spec) + else flcSetColor (fillBorderColor spec) + flcBeginLine + mapM_ (flcVertex . toPrecisePosition) (roundedBoxPoints (fillBounds spec) (Just (fillCornerRadius spec)) Nothing) + flcEndLine + flcLineStyle (LineDrawStyle (Just LineStyleSolid) Nothing Nothing) Nothing Nothing + flcSetColor oldColor + +-- | Draw a box according to the 'FillSpec'. It was originally intended for custom "Graphics.UI.FLTK.Theme.Light.Button" +-- which is why it takes a 'Bool' specifies if the button is pressed but is used widely in the theme for any rounded +-- rectangular area. +fillRectangle :: FillSpec -> Bool -> IO () +fillRectangle spec pressed = do + if pressed + then drawButton (fillTopSelectionColor spec) (fillBottomSelectionColor spec) + else drawButton (fillTopColor spec) (fillBottomColor spec) + where + drawButton topColor bottomColor = do + let diameter = (fillCornerRadius spec) * 2 + quarterCircle x y a1 a2 = do + fillColor <- flcColor + flcPie (toRectangle (x,y,diameter,diameter)) a1 a2 + flcSetColor fillColor + oldColor <- flcColor + -- top left/right + let (x,y,w,h) = fromRectangle (fillBounds spec) + insideW = w + insideH = h + topFillFraction :: Double + topFillFraction = (fromIntegral (fillTopFillPercentage spec)) / 100.0 + topHeight = truncate (fromIntegral insideH * topFillFraction) + flcSetColor topColor + flcRectf (toRectangle (x + (fillCornerRadius spec), y, insideW - diameter, (fillCornerRadius spec))) + flcRectf (toRectangle (x, y + (fillCornerRadius spec), insideW , topHeight - (fillCornerRadius spec))) + -- bottom left/right + let bottomFillFraction :: Double + bottomFillFraction = (fromIntegral (fillBottomFillPercentage spec)) / 100.0 + bottomHeight = truncate (fromIntegral insideH * bottomFillFraction) + flcSetColor bottomColor + when (diameter > 0) + (do + quarterCircle x y (PreciseAngle 90.0) (PreciseAngle 180.0) + quarterCircle (x + (insideW - diameter)) y (PreciseAngle 0) (PreciseAngle 90.0) + quarterCircle x (y + (insideH - diameter)) (PreciseAngle 180.0) (PreciseAngle 270.0) + quarterCircle (x + (insideW - diameter)) (y + (insideH - diameter)) (PreciseAngle 270.0) (PreciseAngle 360.0) + flcRectf (toRectangle (x + (fillCornerRadius spec), y + h - (fillCornerRadius spec), insideW - (diameter), (fillCornerRadius spec)))) + flcRectf (toRectangle (x, y + bottomHeight, insideW, h - bottomHeight - (fillCornerRadius spec))) + -- middle gradient + let middleFraction = fromIntegral (fillBottomFillPercentage spec - fillTopFillPercentage spec) / 100.0 + totalSteps :: Double + totalSteps = fromIntegral h * middleFraction + stepSize :: Double + stepSize = 1.0 / totalSteps + mapM_ + ( + \step -> do + let weight = 1.0 - (stepSize * fromIntegral step) + blendColor = + colorAverage + topColor + bottomColor + weight + flcSetColor blendColor + flcXyline (toPosition (x,y + topHeight + step)) (X (x + insideW - 1)) + ) + [0 .. truncate totalSteps - 1] + flcSetColor oldColor + +-- | Return the 'Position' which centers the given 'Size' in 'Rectangle'. +centerInRectangle :: Rectangle -> Size -> Position +centerInRectangle r (Size (Width sW) (Height sH)) = + let (rX,rY,rW,rH) = fromRectangle r + posX = rX + ((rW-sW) `intDiv` 2) + posY = rY + ((rH-sH) `intDiv` 2) + in toPosition (posX,posY) + +-- | Return the 'Rectangle' that is centered in the given 'Rectangle' by the +-- 'X' and 'Y' /offset/ , so for example, (X 20) (Y 20) returns +-- a 'Rectangle' with a top left coordinate which is 20 pixels over and 20 +-- pixels below the top left of the given 'Rectangle'. +centerInRectangleByRelativePosition :: Rectangle -> X -> Y -> Rectangle +centerInRectangleByRelativePosition r (X xOff) (Y yOff) = + let (rX,rY,rW,rH) = fromRectangle r + r2W = rW - (2*xOff) + r2H = rH - (2*yOff) + in toRectangle (rX+xOff,rY+yOff,r2W,r2H) + +-- | Return a 'Rectangle' of 'Size' positioned at 'X' and 'Y' inside the given +-- 'Rectangle'. It's on the caller to make sure that the resulting 'Rectangle' +-- actually fits inside the one passed in. 'Size', 'X' and 'Y' are +-- not checked. +positionInside :: Rectangle -> Size -> X -> Y -> Rectangle +positionInside r (Size (Width sW) (Height sH)) (X xOff) (Y yOff) = + let (rX,rY,rW,rH) = fromRectangle r + in toRectangle (rX+xOff,rY+yOff,sW,sH) + +-- | Transform the height. +withSizeHeight :: Size -> (Height -> Height) -> Size +withSizeHeight (Size w h) f = Size w (f h) + +-- | Transform the width. +withSizeWidth :: Size -> (Width -> Width) -> Size +withSizeWidth (Size w h) f = Size (f w) h + +-- | Transform the X coordinate of a location +withPositionX :: Position -> (X -> X) -> Position +withPositionX (Position x y) f = Position (f x) y + +-- | Transform the Y coordinate of a location +withPositionY :: Position -> (Y -> Y) -> Position +withPositionY (Position x y) f = Position x (f y) + +-- | Split the width of the 'Rectangle' into two side-by-side +-- ('Rectangle','Rectangle') by the 'Double' %. % must be between 0.0 and 1.0. +-- The width of the 2 returned rectangles will always sum to the width of the +-- one passed in. +splitVertically :: Rectangle -> Double -> (Rectangle, Rectangle) +splitVertically r percent = + let (rx,ry,rw,rh) = fromRectangle r + r1w = truncate ((fromIntegral rw) * percent) + r2w = rw-r1w + r2x = rx+r1w + in (toRectangle (rx,ry,r1w,rh), toRectangle (r2x,ry,r2w,rh)) + +-- | Like 'splitVertically' but takes a 'Int' pixel width instead of a %. If the +-- width is greater than the 'Rectangle' the first of the pair will be the +-- 'Rectangle' passed in and the second will have the same dimensions but a 0 +-- width. +splitVerticallyByPixels :: Rectangle -> Int -> (Rectangle, Rectangle) +splitVerticallyByPixels r ps = + let (rx,ry,rw,rh) = fromRectangle r + r1w = if (ps >= rw) then rw else ps + r2w = rw-r1w + r2x = rx+r1w + in (toRectangle (rx,ry,r1w,rh), toRectangle (r2x,ry,r2w,rh)) + +-- | Split the height of the 'Rectangle' into two stacked +-- ('Rectangle','Rectangle') by the 'Double' %. % must be between 0.0 and 1.0. +-- The height of the 2 returned rectangles will always sum to the height of the +-- one passed in. +splitHorizontally :: Rectangle -> Double -> (Rectangle, Rectangle) +splitHorizontally r percent = + let (rx,ry,rw,rh) = fromRectangle r + r1h = truncate ((fromIntegral rh) * percent) + r2h = rh-r1h + r2y = ry+r1h + in (toRectangle (rx,ry,rw,r1h), toRectangle (rx,r2y,rw,r2h)) + +-- | Like 'splitHorizontally' but takes a 'Int' pixel height instead of a %. If the +-- height is greater than the 'Rectangle' the first of the pair will be the +-- 'Rectangle' passed in and the second will have the same dimensions but a 0 +-- height. +splitHorizontallyByPixels :: Rectangle -> Int -> (Rectangle,Rectangle) +splitHorizontallyByPixels r ps = + let (rx,ry,rw,rh) = fromRectangle r + r1h = if (ps >= rh) then rh else ps + r2h = rh-r1h + r2y = ry+r1h + in (toRectangle (rx,ry,rw,r1h), toRectangle (rx,r2y,rw,r2h)) + +-- | A lossy division of 'Int'/'Int'. The result is 'truncate'd but it's good +-- enough for widget dimensions which is the primary use-case. +intDiv :: Int -> Int -> Int +intDiv num denom = truncate (((fromIntegral num) / (fromIntegral denom)) :: Double) + +-- | Needs to be called by every app to load the themes's resources and do some +-- minor setup See "Graphics.UI.FLTK.Theme.Light#GettingStarted" for more +-- information. +configureTheme :: IO Assets +configureTheme = do + assets <- loadAssets + let ?assets = assets + FL.setColor background2Color lightBackground + tooltipSetFont commonFont + tooltipSetSize commonFontSize + return assets diff --git a/src/Graphics/UI/FLTK/Theme/Light/Counter.hs b/src/Graphics/UI/FLTK/Theme/Light/Counter.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/FLTK/Theme/Light/Counter.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE ImplicitParams, ScopedTypeVariables, OverloadedStrings #-} +module Graphics.UI.FLTK.Theme.Light.Counter + ( + counterNew, + -- * Counter drawing and handling helpers + counterComponentsBounds, + drawCounter, + handleCounter + ) +where +import Control.Exception +import Control.Monad +import Data.IORef +import Data.List +import Graphics.UI.FLTK.LowLevel.Fl_Enumerations +import Graphics.UI.FLTK.LowLevel.Fl_Types +import Graphics.UI.FLTK.Theme.Light.Button +import Graphics.UI.FLTK.Theme.Light.Common +import Graphics.UI.FLTK.Theme.Light.Input +import qualified Data.Text as T +import qualified Graphics.UI.FLTK.LowLevel.FL as FL +import qualified Graphics.UI.FLTK.LowLevel.FLTKHS as LowLevel +import Graphics.UI.FLTK.Theme.Light.Assets + +data CounterButton = NormalLL | NormalL | NormalR | NormalRR | SimpleL | SimpleR deriving (Eq,Show) + +counterComponentsBounds :: LowLevel.CounterType -> Rectangle -> [Rectangle] +counterComponentsBounds c rect = + let (x',y',w',h') = fromRectangle rect + in + case c of + LowLevel.SimpleCounterType -> + let arrowButtonWidth = (w'*20) `intDiv` 100 + inputWidth = w' - ((w'*40) `intDiv` 100) + in + [ + toRectangle (x',y',arrowButtonWidth,h') + , toRectangle (x'+arrowButtonWidth+inputWidth,y',arrowButtonWidth,h') + , toRectangle (x'+arrowButtonWidth,y',w'-(arrowButtonWidth*2),h') + ] + LowLevel.NormalCounterType -> + let arrowButtonWidth = (w'*15) `intDiv` 100 + in + [ + toRectangle (x',y',arrowButtonWidth,h') + , toRectangle (x'+arrowButtonWidth,y',arrowButtonWidth,h') + , toRectangle (x'+w'-arrowButtonWidth-arrowButtonWidth,y',arrowButtonWidth,h') + , toRectangle (x'+w'-arrowButtonWidth,y',arrowButtonWidth,h') + , toRectangle (x'+arrowButtonWidth+arrowButtonWidth,y',w'-(arrowButtonWidth*4),h') + ] + +calculatePressedButton :: Position -> Ref LowLevel.Counter -> IO (Either () (Maybe CounterButton)) +calculatePressedButton pos c = do + r <- LowLevel.getRectangle c + ct <- LowLevel.getType_ c + let cl = counterComponentsBounds ct r + normalComponenets = [NormalLL,NormalL,NormalR,NormalRR] + simpleComponents = [SimpleL,SimpleR] + case cl of + (dl:l:r:rr:_:[]) -> do + let events = map (\r -> insideRectangle pos r) [dl,l,r,rr] + return (maybe (Right Nothing) (\i -> (Right (Just (normalComponenets !! i)))) (Data.List.elemIndex True events)) + (l:r:_:[]) -> do + let events = map (\r -> insideRectangle pos r) [l,r] + return (maybe (Right Nothing) (\i -> (Right (Just (simpleComponents !! i)))) (Data.List.elemIndex True events)) + _ -> throwIO (userError "A Counter can only have 3 or 5 widget components.") + +drawCounter :: (?assets :: Assets) => IORef (Either () (Maybe CounterButton)) -> Ref LowLevel.Counter -> IO () +drawCounter pressedRef c = + let arrowBox :: Color -> Rectangle -> Bool -> Ref LowLevel.PNGImage -> IO () + arrowBox color rect pressed logo = do + selectionColor <- LowLevel.getSelectionColor c + fontSize <- LowLevel.getLabelsize c + spec <- makeFillSpec rect color selectionColor + fillRectangle (spec { fillCornerRadius = 0 }) pressed + LowLevel.flcBeginLine + mapM_ (LowLevel.flcVertex . toPrecisePosition) (roundedBoxPoints rect Nothing Nothing) + LowLevel.flcEndLine + logoSize <- LowLevel.getDataSize logo + LowLevel.draw logo (centerInRectangle rect logoSize) + in do + pressed <- readIORef pressedRef + color <- LowLevel.getColor c + ct <- LowLevel.getType_ c + r <- LowLevel.getRectangle c + let cl = counterComponentsBounds ct r + numButtons = length cl - 1 + valueBoxRect = last cl + mapM_ (\(a,b,c)-> arrowBox color a b c) + (zip3 (take (length cl - 1) cl) + (case pressed of + Left _ -> [False,False,False,False] + Right Nothing -> [False,False,False,False] + Right (Just NormalLL) -> [True,False,False,False] + Right (Just NormalL) -> [False,True,False,False] + Right (Just NormalR) -> [False,False,True,False] + Right (Just NormalRR) -> [False,False,False,True] + Right (Just SimpleL) -> [True,False] + Right (Just SimpleR) -> [False,True]) + (if (numButtons == 4) + then [rewindImage,leftImage,rightImage,forwardImage] + else [leftImage,rightImage])) + str <- LowLevel.format c + LowLevel.flcRectfWithColor valueBoxRect color + inputBox False valueBoxRect color + case str of + Left _ -> LowLevel.flcDrawInBox "" valueBoxRect (Alignments [AlignTypeCenter]) Nothing Nothing + Right s -> LowLevel.flcDrawInBox s valueBoxRect (Alignments [AlignTypeCenter]) Nothing Nothing + +handleCounter :: IORef (Either () (Maybe CounterButton )) -> Ref LowLevel.Counter -> Event -> IO (Either UnknownEvent ()) +handleCounter pressedRef c e = do + pressed <- readIORef pressedRef + let setPressed = do + pos <- FL.eventPosition + i <- calculatePressedButton pos c + when (i /= pressed) (writeIORef pressedRef i) + case e of + Release -> do + case pressed of + Right _ -> writeIORef pressedRef (Left ()) + Left _ -> return () + Push -> setPressed + Drag -> setPressed + _ -> return () + LowLevel.handleSuper c e + +counterNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.Counter) +counterNew rect l = do + i <- newIORef (Left ()) + c <- LowLevel.counterCustom rect l (Just (drawCounter i)) + (Just (LowLevel.defaultCustomWidgetFuncs + { + LowLevel.handleCustom = Just (handleCounter i) + })) + LowLevel.setColor c lightBackground + LowLevel.setBox c BorderBox + LowLevel.setTextfont c commonFont + LowLevel.setTextsize c commonFontSize + color <- commonSelectionColor + LowLevel.setSelectionColor c color + LowLevel.setLabelfont c commonFont + LowLevel.setLabelsize c commonFontSize + return c diff --git a/src/Graphics/UI/FLTK/Theme/Light/Dial.hs b/src/Graphics/UI/FLTK/Theme/Light/Dial.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/FLTK/Theme/Light/Dial.hs @@ -0,0 +1,230 @@ +{-# LANGUAGE ImplicitParams, ScopedTypeVariables, OverloadedStrings, AllowAmbiguousTypes, GADTs, CPP, ExistentialQuantification, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, ScopedTypeVariables, UndecidableInstances #-} +module Graphics.UI.FLTK.Theme.Light.Dial + ( + dialNew, + fillDialNew, + lineDialNew, + drawDial + ) +where +import Control.Exception +import Control.Monad +import Data.List +import Graphics.UI.FLTK.LowLevel.Dispatch +import Graphics.UI.FLTK.LowLevel.Fl_Enumerations +import Graphics.UI.FLTK.LowLevel.Fl_Types +import Graphics.UI.FLTK.Theme.Light.Common +import Text.Printf +import qualified Data.ByteString.Char8 as BC +import qualified Data.Text as T +import qualified Graphics.UI.FLTK.LowLevel.FL as FL +import qualified Graphics.UI.FLTK.LowLevel.FLTKHS as LowLevel +import Graphics.UI.FLTK.Theme.Light.Assets + +dialOutline w h rW rH a1X a1Y rWWithStroke rHWithStroke bigCircle a2X a2Y sw colorString = + "" + ++ "" + ++ "" + +meter w h rW rH meterCenter meterX meterY mw = + "" + ++ "" + ++ "" + ++ "" + +fillEllipse w h rW rH startX startY rWWithStroke rHWithStroke bigCircle endX endY colorString = + "" + ++ "" + ++ "" + +arrow = + [ + "" + , "" + , "" + , "" + ] + +makeDialOutline :: Size -> PreciseAngle -> PreciseAngle -> String -> String +makeDialOutline (Size (Width w) (Height h)) a1 a2 colorString = + let ((rW,rH) :: (Double,Double)) = center w h + PrecisePosition (PreciseX a1X) (PreciseY a1Y) = angleToCoordinate (fromFltkAngle a1) + PrecisePosition (PreciseX a2X) (PreciseY a2Y) = angleToCoordinate (fromFltkAngle a2) + sw = strokeWidth (PreciseSize (PreciseWidth rW) (PreciseHeight rH)) + in + dialOutline w h rW rH (a1X * (rW-(sw/2))) ((-a1Y) * (rH-(sw/2))) (rW-(sw/2)) (rH-(sw/2)) (if (a1 < a2) then (1 :: Int) else (0 :: Int)) (a2X * (rW-(sw/2))) ((-a2Y) * (rH-(sw/2))) sw colorString + +center :: Int -> Int -> (Double,Double) +center w h = (fromIntegral w / 2, fromIntegral h / 2) + +strokeWidth = percentOfSmallerEllipseRadius 10 +meterCenterRadius = percentOfSmallerEllipseRadius 8 +meterWidth = percentOfSmallerEllipseRadius 5 +knobPadding = percentOfSmallerEllipseRadius 3 +arrowBase = percentOfSmallerEllipseRadius 25 +arrowHeight = percentOfSmallerEllipseRadius 20 +arrowPadding = percentOfSmallerEllipseRadius 15 + +makeMeter :: PreciseAngle -> Size -> String +makeMeter angle (Size (Width w) (Height h)) = + let (rW,rH) = center w h + meterLength = if (rW < rH) then rW else rH + PrecisePosition (PreciseX x) (PreciseY y) = angleToCoordinate (fromFltkAngle angle) + sw :: Double + sw = strokeWidth (PreciseSize (PreciseWidth rW) (PreciseHeight rH)) + meterCenter = meterCenterRadius (PreciseSize (PreciseWidth rW) (PreciseHeight rH)) + mw = meterWidth (PreciseSize (PreciseWidth rW) (PreciseHeight rH)) + in + meter w h rW rH meterCenter (x * (meterLength - sw - (mw / 2))) ((-y) * (meterLength - sw - (mw / 2))) mw + +makeFill :: Size -> PreciseAngle -> PreciseAngle -> String -> String +makeFill (Size (Width w) (Height h)) a1@(PreciseAngle a1') a2@(PreciseAngle a2') colorString = + let ((rW,rH) :: (Double,Double)) = center w h + PrecisePosition (PreciseX a1X) (PreciseY a1Y) = angleToCoordinate (fromFltkAngle a1) + PrecisePosition (PreciseX a2X) (PreciseY a2Y) = angleToCoordinate (fromFltkAngle a2) + sw = strokeWidth (PreciseSize (PreciseWidth rW) (PreciseHeight rH)) + in + fillEllipse w h rW rH (a1X * (rW-sw)) ((-a1Y) * (rH-sw)) (rW-sw) (rH-sw) (if (abs (a2'-a1') < 180) then (0 :: Int) else (1 :: Int)) (a2X * (rW-sw)) ((-a2Y) * (rH-sw)) colorString + +makeArrow :: Size -> PreciseAngle -> String +makeArrow (Size (Width w) (Height h)) a = + let ((rW,rH) :: (Double,Double)) = center w h + sw = strokeWidth (PreciseSize (PreciseWidth rW) (PreciseHeight rH)) + circleR = if (rW"] ++ svgs ++ [""])) + +-- | Custom dial drawing function +drawDial :: Ref LowLevel.Dial -> IO () +drawDial d = do + bounds@(Rectangle dialPos@(Position (X dialX) (Y dialY)) dialSize@(Size (Width dialW) (Height dialH))) <- LowLevel.getRectangle d + p <- LowLevel.getParent d + color <- maybe (return lightBackground) LowLevel.getColor p + drawBorderBox d + (BorderBoxSpec + { + borderBoxBounds = bounds + , borderBoxFocusedColor = color + , borderBoxHoveringColor = color + , borderBoxColor = color + , borderBoxFillColor = color + }) + True + color <- fmap (\c -> colorAverage c blackColor 0.80) (LowLevel.getColor d) + (colorR,colorG,colorB) <- FL.getColorRgb color + (Angle a1) <- LowLevel.getAngle1 d + (Angle a2) <- LowLevel.getAngle2 d + let dialOutlineSvg = makeDialOutline dialSize (PreciseAngle (fromIntegral a1)) (PreciseAngle (fromIntegral a2)) ("rgb(" ++ show colorR ++ "," ++ show colorG ++ "," ++ show colorB ++ ")") + dialMin <- LowLevel.getMinimum d + dialMax <- LowLevel.getMaximum d + when (dialMin>dialMax) (throwIO (userError ("Dial minimum cannot be less than maximum:(" ++ (show dialMin) ++ "," ++ (show dialMax) ++ ")"))) + dialV <- LowLevel.getValue d >>= LowLevel.clamp d + dialType <- LowLevel.getType_ d + let dialLocation = (dialV-dialMin) / (dialMax-dialMin) + let meterAngle = PreciseAngle (((fromIntegral (a2-a1)) * dialLocation) + (fromIntegral a1)) + (selectionColorR, selectionColorG, selectionColorB) <- LowLevel.getSelectionColor d >>= FL.getColorRgb + let svg = + case dialType of + LowLevel.FillDialType -> + wrapSvgs + [ + dialOutlineSvg + , if (a1 + wrapSvgs + [ + dialOutlineSvg + , makeMeter meterAngle dialSize + ] + LowLevel.NormalDialType -> + wrapSvgs + [ + dialOutlineSvg + , makeArrow dialSize meterAngle + ] + iE <- LowLevel.svgImageNew (BC.pack svg) + case iE of + Left _ -> throwIO (userError ("drawDial: the generated SVG is invalid: \n" ++ svg)) + Right i -> do + LowLevel.draw i dialPos + LowLevel.destroy i + LowLevel.drawLabel d Nothing + +dialNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.Dial) +dialNew rectangle label = do + d <- LowLevel.dialCustom + rectangle + label + (Just drawDial) + Nothing + color <- commonColor + LowLevel.setColor d color + color <- commonFillColor + LowLevel.setSelectionColor d color + LowLevel.setLabelfont d commonFont + LowLevel.setLabelsize d commonFontSize + return d + +fillDialNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.FillDial) +fillDialNew rect l = do + d <- dialNew rect l + LowLevel.setType d LowLevel.FillDialType + return (castTo d) + +lineDialNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.LineDial) +lineDialNew rect l = do + d <- dialNew rect l + LowLevel.setType d LowLevel.LineDialType + return (castTo d) diff --git a/src/Graphics/UI/FLTK/Theme/Light/Group.hs b/src/Graphics/UI/FLTK/Theme/Light/Group.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/FLTK/Theme/Light/Group.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE ImplicitParams, OverloadedStrings, AllowAmbiguousTypes, GADTs, CPP, ExistentialQuantification, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, ScopedTypeVariables, UndecidableInstances #-} +module Graphics.UI.FLTK.Theme.Light.Group + ( + groupNew, + scrolledNew + ) +where +import Graphics.UI.FLTK.LowLevel.Fl_Types +import Graphics.UI.FLTK.Theme.Light.Common +import qualified Data.Text as T +import qualified Graphics.UI.FLTK.LowLevel.FLTKHS as LowLevel +import Graphics.UI.FLTK.Theme.Light.Assets + +scrolledNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.Scrolled) +scrolledNew rectangle label = do + s <- LowLevel.scrolledNew rectangle label + p <- LowLevel.getParent s + color <- maybe (return lightBackground) LowLevel.getColor p + LowLevel.setColor s color + LowLevel.setLabelfont s commonFont + LowLevel.setLabelsize s commonFontSize + return s + +groupNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.Group) +groupNew rectangle label = do + g <- LowLevel.groupNew rectangle label + p <- LowLevel.getParent g + color <- maybe (return lightBackground) LowLevel.getColor p + LowLevel.setColor g color + LowLevel.setLabelfont g commonFont + LowLevel.setLabelsize g commonFontSize + color <- commonSelectionColor + LowLevel.setSelectionColor g color + return g diff --git a/src/Graphics/UI/FLTK/Theme/Light/Input.hs b/src/Graphics/UI/FLTK/Theme/Light/Input.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/FLTK/Theme/Light/Input.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE ImplicitParams, ScopedTypeVariables, OverloadedStrings, AllowAmbiguousTypes, GADTs, CPP, ExistentialQuantification, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, ScopedTypeVariables, UndecidableInstances #-} +module Graphics.UI.FLTK.Theme.Light.Input + ( + fileInputNew, + inputBox, + inputNew, + outputNew, + inputSetup, + inputDraw + ) +where +import Control.Monad +import Graphics.UI.FLTK.LowLevel.Dispatch +import Graphics.UI.FLTK.LowLevel.Fl_Enumerations +import Graphics.UI.FLTK.LowLevel.Fl_Types +import Graphics.UI.FLTK.Theme.Light.Common +import qualified Data.Text as T +import qualified Graphics.UI.FLTK.LowLevel.FL as FL +import qualified Graphics.UI.FLTK.LowLevel.FLTKHS as LowLevel +import Graphics.UI.FLTK.Theme.Light.Assets + +inputBox :: Bool -> Rectangle -> Color -> IO () +inputBox focused r c = + if focused + then do + color <- commonFillColor + LowLevel.flcRectWithColor r color + else + let slightlyDarker = colorAverage c blackColor 0.75 + (x',y',w',_) = fromRectangle r + in do + LowLevel.flcRectWithColor r slightlyDarker + LowLevel.flcSetColor blackColor + LowLevel.flcBeginLine + LowLevel.flcVertex (toPrecisePosition (toPosition (x',y'))) + LowLevel.flcVertex (toPrecisePosition (toPosition (x'+w'-1,y'))) + LowLevel.flcEndLine + +inputDraw :: Ref LowLevel.Input -> IO () +inputDraw i = + withCustomBoxDraw + BorderBox + (\rect color -> do + LowLevel.flcRectfWithColor rect color + focused <- isWidget i FL.focus + inputBox focused rect color) + (do + t <- LowLevel.getInputType i + r <- LowLevel.getRectangle i + rBox <- FL.adjustBoundsByBoxtype r BorderBox + case t of + LowLevel.FlHiddenInput -> return () + _ -> do + ds <- LowLevel.getDamage i + if (DamageAll `elem` ds) + then do + color <- LowLevel.getColor i + LowLevel.drawBoxWithBoxtype i BorderBox color Nothing + else + when (DamageExpose `elem` ds) + (do + focused <- isWidget i FL.focus + color <- LowLevel.getColor i + inputBox focused rBox color) + LowLevel.drawText i rBox) + +-- | Common setup function for all 'Input' widgets, sets label color, font etc. +inputSetup :: (?assets :: Assets) => Ref LowLevel.Input -> IO () +inputSetup i = do + LowLevel.setColor i lightBackground + LowLevel.setBox i BorderBox + LowLevel.setTextfont i commonFont + LowLevel.setTextsize i commonFontSize + color <- commonSelectionColor + LowLevel.setSelectionColor i color + LowLevel.setLabelfont i commonFont + LowLevel.setLabelsize i commonFontSize + +inputNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> Maybe LowLevel.FlInputType -> IO (Ref LowLevel.Input) +inputNew rect l it = do + i <- LowLevel.inputCustom rect l it (Just inputDraw) Nothing + inputSetup i + return i + +fileInputNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.FileInput) +fileInputNew rect l = do + i <- LowLevel.fileInputNew rect l + inputSetup (safeCast i) + return i + +outputNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> Maybe LowLevel.FlOutputType -> IO (Ref LowLevel.Output) +outputNew rect l t = do + o <- LowLevel.outputCustom rect l + (Just (inputDraw . safeCast)) + Nothing + inputSetup (safeCast o) + maybe (return ()) (\t -> LowLevel.setType o t) t + return o diff --git a/src/Graphics/UI/FLTK/Theme/Light/Menu.hs b/src/Graphics/UI/FLTK/Theme/Light/Menu.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/FLTK/Theme/Light/Menu.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE ImplicitParams, OverloadedStrings, AllowAmbiguousTypes, GADTs, CPP, ExistentialQuantification, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, ScopedTypeVariables, UndecidableInstances #-} +module Graphics.UI.FLTK.Theme.Light.Menu + ( + choiceNew, + sysMenuBarNew + ) +where +import Graphics.UI.FLTK.LowLevel.Fl_Enumerations +import Graphics.UI.FLTK.LowLevel.Fl_Types +import Graphics.UI.FLTK.Theme.Light.Common +import qualified Data.Text as T +import qualified Graphics.UI.FLTK.LowLevel.FLTKHS as LowLevel +import Graphics.UI.FLTK.Theme.Light.Assets + +sysMenuBarNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.SysMenuBar) +sysMenuBarNew rectangle label = do + let customDraw :: Ref LowLevel.SysMenuBar -> IO () + customDraw m = do + (color :: Color) <- LowLevel.getColor m + let slightlyDarker = colorAverage color blackColor 0.80 + items <- LowLevel.getMenu m + mapM_ + (\miMaybe -> + maybe + (return ()) + (\mi -> do + LowLevel.setLabelfont mi commonFont + LowLevel.setLabelsize mi commonFontSize) + miMaybe) + items + withCustomBoxDraw + BorderBox + (\rect _ -> do + let (x',y',w',h') = fromRectangle rect + LowLevel.flcSetColor slightlyDarker + LowLevel.flcBeginLine + LowLevel.flcVertex (toPrecisePosition (toPosition (x',y'+h'))) + LowLevel.flcVertex (toPrecisePosition (toPosition (x'+w',y'+h'))) + LowLevel.flcEndLine + LowLevel.flcSetColor color + ) + (LowLevel.drawSuper m) + m <- LowLevel.sysMenuBarCustom + rectangle + label + (Just customDraw) + Nothing + LowLevel.setBox m BorderBox + LowLevel.setColor m lightBackground + LowLevel.setTextfont m commonFont + LowLevel.setTextsize m commonFontSize + return m + +choiceNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.Choice) +choiceNew rectangle label = do + c <- LowLevel.choiceCustom + rectangle + label + (Just drawChoice) + Nothing + let color = lightBackground + LowLevel.setLabelfont c commonFont + LowLevel.setLabelsize c commonFontSize + LowLevel.setTextfont c commonFont + LowLevel.setTextsize c commonFontSize + LowLevel.setColor c color + color <- commonSelectionColor + LowLevel.setSelectionColor c color + return c + +drawChoice :: Ref LowLevel.Choice -> IO () +drawChoice c = do + color <- LowLevel.getColor c + selectionColor <- fmap darker (LowLevel.getSelectionColor c) + bounds' <- LowLevel.getRectangle c + let (x,y,w,h) = fromRectangle bounds' + let slightlyDarker = colorAverage color blackColor 0.85 + hoverColor <- rgbColorWithRgb (0xBB, 0xBB, 0xBB) + let spec = + BorderBoxSpec + { + borderBoxHoveringColor = hoverColor, + borderBoxColor = slightlyDarker, + borderBoxFocusedColor = selectionColor, + borderBoxFillColor = color, + borderBoxBounds = toRectangle (x,y,w-1,h-1) + } + withCustomBoxDraw UpBox (\_ _ -> drawBorderBox c spec True) (LowLevel.drawSuper c) diff --git a/src/Graphics/UI/FLTK/Theme/Light/Misc.hs b/src/Graphics/UI/FLTK/Theme/Light/Misc.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/FLTK/Theme/Light/Misc.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE ImplicitParams #-} +module Graphics.UI.FLTK.Theme.Light.Misc + ( + header + , darkHeader + ) +where +import qualified Graphics.UI.FLTK.LowLevel.FLTKHS as LowLevel +import qualified Data.Text as T +import Graphics.UI.FLTK.LowLevel.Fl_Types +import Graphics.UI.FLTK.LowLevel.Fl_Enumerations +import Graphics.UI.FLTK.Theme.Light.Common +import Graphics.UI.FLTK.Theme.Light.Assets + +drawBackground :: (?assets :: Assets) => Color -> FillSpec -> Alignments -> LowLevel.Ref LowLevel.Box -> IO () +drawBackground c spec alignments b = do + r <- LowLevel.getRectangle b + fillRectangle (spec { fillBounds = r }) False + LowLevel.drawLabel b (Just (r,alignments)) + +-- | This widget was intended for use as a app header bar, similar to the one provided by +-- [GTK3](https://developer.gnome.org/gtk3/stable/GtkHeaderBar.html) but really +-- it's just a "Graphics.UI.FLTK.LowLevel.Box" labeled with 'T.Text' and with a background vertically graded +-- with the 'Color' provided. You can use it for anything you like. For a more "turn-key" app +-- header that works nicely with the Light theme you probably want 'darkHeader'. +header :: (?assets :: Assets) => Color -> Rectangle -> T.Text -> Alignments -> IO (LowLevel.Ref LowLevel.Box) +header c r l alignments = + let fillSpec = + FillSpec + { + fillBounds = r + , fillTopColor = c + , fillTopSelectionColor = c + , fillTopFillPercentage = 10 + , fillBottomColor = darker c + , fillBottomSelectionColor = c + , fillBottomFillPercentage = 90 + , fillCornerRadius = 0 + , fillBorderColor = c + , fillBorderFocusColor = c + , fillBorderHovered = c + } + in do + b <- LowLevel.boxCustom r (Just l) (Just (drawBackground c fillSpec alignments)) Nothing + LowLevel.setLabel b l + return b + +-- | Same as 'header' except it doesn't take a 'Color' and uses the 'commonDarkGreyColor' and the +-- a large 'josefinSlabSemiBold' font for the label. +darkHeader :: (?assets :: Assets) => Rectangle -> T.Text -> Alignments -> IO (LowLevel.Ref LowLevel.Box) +darkHeader r l alignments = do + c <- commonDarkGreyColor + b <- header c r l alignments + LowLevel.setLabelfont b josefinSlabSemiBold + LowLevel.setLabelsize b commonLargeFontSize + LowLevel.setLabelcolor b whiteColor + return b diff --git a/src/Graphics/UI/FLTK/Theme/Light/Positioner.hs b/src/Graphics/UI/FLTK/Theme/Light/Positioner.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/FLTK/Theme/Light/Positioner.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE ImplicitParams, ScopedTypeVariables #-} +module Graphics.UI.FLTK.Theme.Light.Positioner + ( + positionerNew + ) +where +import Graphics.UI.FLTK.Theme.Light.Common +import qualified Data.Text as T +import qualified Graphics.UI.FLTK.LowLevel.FLTKHS as LowLevel +import Graphics.UI.FLTK.LowLevel.Fl_Enumerations +import Graphics.UI.FLTK.Theme.Light.Assets + +positionerNew :: (?assets :: Assets) => LowLevel.Rectangle -> Maybe T.Text -> IO (LowLevel.Ref LowLevel.Positioner) +positionerNew rect l = do + let customDraw :: LowLevel.Ref LowLevel.Positioner -> IO () + customDraw p = do + (color :: Color) <- LowLevel.getColor p + let slightlyDarker = colorAverage color blackColor 0.85 + withCustomBoxDraw + BorderBox + (\rect _ -> do + LowLevel.flcRectfWithColor rect color + LowLevel.flcRectWithColor rect slightlyDarker) + (LowLevel.drawSuper p) + p <- LowLevel.positionerCustom rect l (Just customDraw) Nothing + LowLevel.setLabelfont p commonFont + LowLevel.setLabelsize p commonFontSize + LowLevel.setColor p lightBackground + LowLevel.setBox p BorderBox + LowLevel.setSelectionColor p redColor + return p diff --git a/src/Graphics/UI/FLTK/Theme/Light/Progress.hs b/src/Graphics/UI/FLTK/Theme/Light/Progress.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/FLTK/Theme/Light/Progress.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE ImplicitParams, OverloadedStrings #-} +module Graphics.UI.FLTK.Theme.Light.Progress + ( + progressNew, + drawProgress + ) +where +import Graphics.UI.FLTK.LowLevel.Fl_Enumerations +import Graphics.UI.FLTK.LowLevel.Fl_Types +import Graphics.UI.FLTK.Theme.Light.Common +import qualified Data.Text as T +import qualified Graphics.UI.FLTK.LowLevel.FLTKHS as LowLevel +import Graphics.UI.FLTK.Theme.Light.Assets + +-- | Custom progress bar drawing function +drawProgress :: Ref LowLevel.Progress -> IO () +drawProgress p = do + rect <- LowLevel.getRectangle p + progressMin <- LowLevel.getMinimum p + progressMax <- LowLevel.getMaximum p + v <- LowLevel.getValue p + color <- LowLevel.getColor p + let (x,y,w,h) = fromRectangle rect + slightlyDarker = colorAverage color blackColor 0.85 + progressW = (truncate ((fromIntegral w) * (v/(progressMax-progressMin)))) + selectionColor <- LowLevel.getSelectionColor p + let fillColor = darker selectionColor + hoverColor <- rgbColorWithRgb (0xBB, 0xBB, 0xBB) + let spec = + BorderBoxSpec + { + borderBoxHoveringColor = hoverColor, + borderBoxColor = slightlyDarker, + borderBoxFocusedColor = fillColor, + borderBoxFillColor = color, + borderBoxBounds = rect + } + drawBorderBox p spec True + LowLevel.flcRectfWithColor (toRectangle (x+1,y+1,progressW,h-2)) selectionColor + +progressNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.Progress) +progressNew rect l = do + p <- LowLevel.progressCustom rect l + (Just drawProgress) + Nothing + LowLevel.setColor p lightBackground + LowLevel.setBox p BorderBox + LowLevel.setLabelfont p commonFont + LowLevel.setLabelsize p commonFontSize + color <- commonFillColor + LowLevel.setSelectionColor p color + return p diff --git a/src/Graphics/UI/FLTK/Theme/Light/SimpleTerminal.hs b/src/Graphics/UI/FLTK/Theme/Light/SimpleTerminal.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/FLTK/Theme/Light/SimpleTerminal.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE ImplicitParams, OverloadedStrings #-} +module Graphics.UI.FLTK.Theme.Light.SimpleTerminal + ( + simpleTerminalNew + ) +where +import Graphics.UI.FLTK.Theme.Light.Common +import qualified Graphics.UI.FLTK.LowLevel.FLTKHS as LowLevel +import qualified Data.Text as T +import Graphics.UI.FLTK.Theme.Light.Assets + +simpleTerminalNew :: (?assets :: Assets) => LowLevel.Rectangle -> Maybe T.Text -> IO (LowLevel.Ref LowLevel.SimpleTerminal) +simpleTerminalNew r l = do + t <- LowLevel.simpleTerminalNew r l + LowLevel.setColor t lightBackground + LowLevel.setTextfont t commonFont + LowLevel.setTextsize t commonFontSize + color <- commonSelectionColor + LowLevel.setSelectionColor t color + LowLevel.setLabelfont t commonFont + LowLevel.setLabelsize t commonFontSize + return t diff --git a/src/Graphics/UI/FLTK/Theme/Light/Slider.hs b/src/Graphics/UI/FLTK/Theme/Light/Slider.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/FLTK/Theme/Light/Slider.hs @@ -0,0 +1,419 @@ +{-# LANGUAGE ImplicitParams, OverloadedStrings, AllowAmbiguousTypes, GADTs, CPP, ExistentialQuantification, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, ScopedTypeVariables, UndecidableInstances #-} +module Graphics.UI.FLTK.Theme.Light.Slider + ( + sliderNew, + fillSliderNew, + valueSliderNew, + gaugeSliderNew, + horFillSliderNew, + horNiceSliderNew, + horSliderNew, + horValueSliderNew, + -- * Slider drawing helpers + -- + -- + GaugeSliderSpec(..), + defaultGaugeHeight, + drawSlider, + drawValueSlider, + gaugeBoxBounds, + sliderIsHorizontal, + mkGaugeSliderSpec, + sliderKnobColor, + sliderSetup + ) +where +import Control.Exception +import Graphics.UI.FLTK.LowLevel.Dispatch +import Graphics.UI.FLTK.LowLevel.Fl_Enumerations +import Graphics.UI.FLTK.LowLevel.Fl_Types +import Graphics.UI.FLTK.Theme.Light.Common +import Text.Printf +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Graphics.UI.FLTK.LowLevel.FL as FL +import qualified Graphics.UI.FLTK.LowLevel.FLTKHS as LowLevel +import qualified Graphics.UI.FLTK.LowLevel.Hierarchy as Hierarchy +import qualified Graphics.UI.FLTK.LowLevel.Dispatch +import Graphics.UI.FLTK.Theme.Light.Assets + +sliderKnobColor :: IO Color +sliderKnobColor = rgbColorWithRgb (241,241,241) + +sliderIsHorizontal :: SliderType -> Bool +sliderIsHorizontal VertSliderType = False +sliderIsHorizontal HorSliderType = True +sliderIsHorizontal VertFillSliderType = False +sliderIsHorizontal HorFillSliderType = True +sliderIsHorizontal VertNiceSliderType = False +sliderIsHorizontal HorNiceSliderType = True + +sliderSetup :: + (?assets :: Assets) => Ref LowLevel.Slider -> IO () +sliderSetup s = do + () <- LowLevel.setColor s lightBackground + () <- LowLevel.setBox s BorderBox + () <- LowLevel.setSlider s UpBox + () <- LowLevel.setSliderSize s 0.15 + () <- LowLevel.setLabelfont s commonFont + () <- LowLevel.setLabelsize s commonFontSize + color <- commonSelectionColor + LowLevel.setSelectionColor s color + +data GaugeSliderSpec = + GaugeSliderSpec + { + gaugeHeight :: Int + , gaugeWidth :: Double + , gaugeOverhang :: Double + } + +defaultGaugeHeight :: Int +defaultGaugeHeight = 10 + +mkGaugeSliderSpec = + GaugeSliderSpec + { + gaugeHeight = defaultGaugeHeight + , gaugeWidth = 0.20 + , gaugeOverhang = (fromIntegral defaultGaugeHeight)/2 + } + +drawValueSlider :: Ref LowLevel.ValueSlider -> IO () +drawValueSlider vs = do + color <- LowLevel.getColor vs + selectionColor <- fmap darker (LowLevel.getSelectionColor vs) + let slightlyDarker = Graphics.UI.FLTK.LowLevel.Fl_Enumerations.colorAverage color blackColor 0.85 + hoverColor <- rgbColorWithRgb (0xBB, 0xBB, 0xBB) + (x,y,w,h) <- fmap fromRectangle (LowLevel.getRectangle vs) + sliderType <- LowLevel.getType_ vs + let spec = + BorderBoxSpec + { + borderBoxHoveringColor = hoverColor, + borderBoxColor = slightlyDarker, + borderBoxFocusedColor = selectionColor, + borderBoxFillColor = color, + borderBoxBounds = + toRectangle + (if (sliderIsHorizontal sliderType) + then (x,y,valueBoxWidth-1,h-1) + else (x,y,w-1, valueBoxHeight-1) + ) + } + drawBorderBox vs spec True + valueFont <- LowLevel.getTextfont vs + valueFontsize <- LowLevel.getTextsize vs + valueFontcolor <- LowLevel.getTextcolor vs + LowLevel.flcSetFont valueFont valueFontsize + isActive <- LowLevel.activeR vs + LowLevel.flcSetColor (if isActive then valueFontcolor else (inactive valueFontcolor)) + currentValue <- LowLevel.format vs + case currentValue of + Left _ -> return () + Right text -> LowLevel.flcDrawInBox text (borderBoxBounds spec) (Alignments [AlignTypeClip]) Nothing Nothing + drawSlider + (castTo vs) + Nothing + (toRectangle + (if (sliderIsHorizontal sliderType) + then (x+valueBoxWidth,y,w-valueBoxWidth,h) + else (x,y+valueBoxHeight,w,h-valueBoxHeight) + ) + ) + where + valueBoxWidth = 35 + valueBoxHeight = 25 + +gaugeBoxBounds :: Bool -> GaugeSliderSpec -> Rectangle -> Rectangle +gaugeBoxBounds horizontal spec rect = + let (x,y,w,h) = fromRectangle rect + horizontalBounds = + ( + x+(truncate (gaugeOverhang spec)) + , y+(truncate ((gaugeWidth spec)*(fromIntegral h))) + , w-(2*(truncate (gaugeOverhang spec))) + , h-(2*(truncate ((gaugeWidth spec)*(fromIntegral h)))) + ) + verticalBounds = + ( + x+(truncate ((gaugeWidth spec)*(fromIntegral w))) + , y+(truncate (gaugeOverhang spec)) + , w-(2*(truncate ((gaugeWidth spec)*(fromIntegral w)))) + , h-(2*(truncate (gaugeOverhang spec))) + ) + in toRectangle (if horizontal then horizontalBounds else verticalBounds) + +drawSlider :: Ref LowLevel.Slider -> Maybe GaugeSliderSpec -> Rectangle -> IO () +drawSlider s gaugeSpec rect = do + color <- LowLevel.getColor s + selectionColor <- fmap darker (LowLevel.getSelectionColor s) + let (x,y,w,h) = fromRectangle rect + slightlyDarker = colorAverage color blackColor 0.85 + hoverColor <- rgbColorWithRgb (0xBB, 0xBB, 0xBB) + t <- LowLevel.getType_ s + let spec = + BorderBoxSpec + { + borderBoxHoveringColor = hoverColor, + borderBoxColor = slightlyDarker, + borderBoxFocusedColor = selectionColor, + borderBoxFillColor = color, + borderBoxBounds = + case gaugeSpec of + Nothing -> toRectangle (x,y,w-1,h-1) + Just spec -> gaugeBoxBounds (sliderIsHorizontal t) spec rect + } + (xDiff,yDiff,wDiff,hDiff) = FL.boxDifferences rect (borderBoxBounds spec) + drawBorderBox s spec (maybe True (\_ -> False) gaugeSpec) + LowLevel.drawLabel s Nothing + min' <- LowLevel.getMinimum s + max' <- LowLevel.getMaximum s + value' <- fmap (sliderValue min' max') (LowLevel.getValue s) + oldColor <- LowLevel.flcColor + case gaugeSpec of + Nothing -> drawPill rect value' (sliderIsHorizontal t) + Just gaugeSpec -> + let (xDiff,yDiff,wDiff,hDiff) = FL.boxDifferences rect (borderBoxBounds spec) + (xPad,yPad) = (xDiff `intDiv` 2, yDiff `intDiv` 2) + in do + LowLevel.flcRectfWithColor (toRectangle (x,y,w,yDiff)) color + LowLevel.flcRectfWithColor (toRectangle (x,y+yDiff,xDiff,h-(yDiff*2))) color + LowLevel.flcRectfWithColor (toRectangle (x+w-xDiff,y+yDiff,xDiff,h-(yDiff*2))) color + LowLevel.flcRectfWithColor (toRectangle (x,y+h-yDiff,w,yDiff)) color + triangleColor <- FL.getColorRgb (colorAverage slightlyDarker blackColor 0.85) + drawGauge (borderBoxBounds spec) triangleColor rect value' (sliderIsHorizontal t) gaugeSpec + where + gaugeSvg (borderR,borderG,borderB) bounds innerBounds v horizontal spec = + let (x',y',w',h') = fromRectangle bounds + (_,_,innerW,innerH) = fromRectangle innerBounds + (doubleX,doubleY,doubleW,doubleH) = (fromIntegral x',fromIntegral y',fromIntegral w',fromIntegral h') + svg = + "\n" + ++ "\n" + ++ "\n" + ++ "\n" + ++ "\n" + ++ "\n" + ++ "\n" + ++ "" + xTranslation = (fromIntegral innerW) * v + yTranslation = (fromIntegral innerH) * v + in + if horizontal + then + printf svg + w' h' xTranslation (0 :: Double) + (0 :: Int) (0 :: Int) + (gaugeHeight spec) (0 :: Int) + (((gaugeHeight spec) `intDiv` 2) :: Int) ((truncate ((gaugeWidth spec)*(fromIntegral h'))) :: Int) + (0 :: Int) (0 :: Int) + ("rgb(" ++ show borderR ++ "," ++ show borderG ++ "," ++ show borderB ++ ")") ("1px" :: String) + (0 :: Int) h' + (gaugeHeight spec) h' + (((gaugeHeight spec) `intDiv` 2) :: Int) (h'-(truncate ((gaugeWidth spec)*(fromIntegral h')))) + (0 :: Int) h' + ("rgb(" ++ show borderR ++ "," ++ show borderG ++ "," ++ show borderB ++ ")") ("1px" :: String) + (0 :: Int) (0 :: Int) + (gaugeHeight spec) (0 :: Int) + ("1px" :: String) + (0 :: Int) h' + (gaugeHeight spec) h' + ("1px" :: String) + else + printf svg + w' h' (0 :: Double) yTranslation + (0 :: Int) (0 :: Int) + (0 :: Int) (gaugeHeight spec) + ((truncate ((gaugeWidth spec)*(fromIntegral w'))) :: Int) (((gaugeHeight spec) `intDiv` 2) :: Int) + (0 :: Int) (0 :: Int) + ("rgb(" ++ show borderR ++ "," ++ show borderG ++ "," ++ show borderB ++ ")") ("1px" :: String) + w' (0 :: Int) + w' (gaugeHeight spec) + (w'-(truncate ((gaugeWidth spec)*(fromIntegral w')))) (((gaugeHeight spec) `intDiv` 2) :: Int) + w' (0 :: Int) + ("rgb(" ++ show borderR ++ "," ++ show borderG ++ "," ++ show borderB ++ ")") ("1px" :: String) + (0 :: Int) (0 :: Int) + (0 :: Int) (gaugeHeight spec) + ("1px" :: String) + w' (0 :: Int) + w' (gaugeHeight spec) + ("1px" :: String) + drawGauge innerBounds borderRgb bounds v horizontal spec = + let svg = gaugeSvg borderRgb bounds innerBounds v horizontal spec + (x,y,_,_) = fromRectangle bounds + in do + iE <- LowLevel.svgImageNew ((TE.encodeUtf8 . T.pack) svg) + case iE of + Left _ -> throwIO (userError ("The generated SVG is invalid: \n" ++ svg)) + Right i -> do + LowLevel.draw i (toPosition (x,y)) + LowLevel.destroy i + pillCornerRadius :: Int + pillCornerRadius = 2 + pillLength :: Double + pillLength = 20.0 + pillCenter :: Double + pillCenter = pillLength / 2.0 + pillPadding :: Int + pillPadding = 3 + pillEndPadding :: Int + pillEndPadding = 2 + sliderValue :: Double -> Double -> Double -> Double + sliderValue min' max' curr' = + if (min' == max') then 0.5 + else + case (curr' - min') / (max' - min') of + val | val > 1.0 -> 1.0 + | val < 0.0 -> 0.0 + | otherwise -> val + pillRectangle :: Bool -> Double -> Rectangle -> Rectangle + pillRectangle horizontal value' (Rectangle (Position (X x') (Y y')) (Size (Width w') (Height h'))) = + if horizontal + then + Rectangle + (Position + (X (truncate (fromIntegral x' + (fromIntegral w' - pillLength) * value'))) + (Y (y'+ pillPadding))) + (Size + (Width (truncate pillLength)) + (Height (h' - (pillPadding * 2) - 1))) + else + Rectangle + (Position + (X (x'+ pillPadding)) + (Y (truncate (fromIntegral y' + ((fromIntegral h' - pillLength) * value'))))) + (Size + (Width (w' - pillPadding*2 - 1)) + (Height (truncate pillLength))) + drawPill rect v horizontal = + let (x,y,w,h) = fromRectangle rect + pill = pillRectangle + horizontal + v + (toRectangle + (if horizontal + then (x+pillEndPadding,y,w-2*pillEndPadding,h) + else (x,y+pillEndPadding,w,h-2*pillEndPadding) + ) + ) + in do + borderColor <- rgbColorWithRgb (0x93,0x93,0x93) + color <- sliderKnobColor + let pillVertices = mapM_ (LowLevel.flcVertex . toPrecisePosition) (roundedBoxPoints pill (Just pillCornerRadius) Nothing) + LowLevel.flcSetColor color + LowLevel.flcBeginPolygon + pillVertices + LowLevel.flcEndPolygon + LowLevel.flcSetColor borderColor + LowLevel.flcBeginLine + pillVertices + LowLevel.flcEndLine + +{-# DEPRECATED fillSliderNew "Fill sliders are not supported in the Light theme. 'fillSliderNew' is the same as 'sliderNew'." #-} +{-# DEPRECATED horFillSliderNew "Fill sliders are not supported in the Light theme. 'horFillSliderNew' is the same as 'sliderNew'." #-} +{-# DEPRECATED horNiceSliderNew "\"Nice\"sliders are not supported in the Light theme. 'horNiceSliderNew' is the same as 'sliderNew'." #-} + + +sliderNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.Slider) +sliderNew rectangle label = do + s <- LowLevel.sliderCustom + rectangle + label + (Just (\s -> do + bounds <- LowLevel.getRectangle s + drawSlider s Nothing bounds + )) + (Just (LowLevel.defaultCustomWidgetFuncs { LowLevel.handleCustom = (Just handleHover) })) + sliderSetup s + return s + +gaugeSliderNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.Slider) +gaugeSliderNew rectangle label = do + s <- LowLevel.sliderCustom + rectangle + label + (Just (\s -> do + bounds <- LowLevel.getRectangle s + drawSlider s (Just mkGaugeSliderSpec) bounds + )) + (Just (LowLevel.defaultCustomWidgetFuncs {LowLevel.handleCustom = Just handleHover})) + sliderSetup (safeCast s) + return s + +valueSliderNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.ValueSlider) +valueSliderNew rectangle label = do + s <- LowLevel.valueSliderCustom + rectangle + label + (Just drawValueSlider) + (Just (LowLevel.defaultCustomWidgetFuncs { LowLevel.handleCustom = (Just handleHover) })) + sliderSetup (safeCast s) + return s + +horValueSliderNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.HorValueSlider) +horValueSliderNew rectangle label = do + s <- LowLevel.valueSliderCustom + rectangle + label + (Just drawValueSlider) + (Just (LowLevel.defaultCustomWidgetFuncs { LowLevel.handleCustom = (Just handleHover) })) + LowLevel.setType s HorSliderType + sliderSetup (safeCast s) + return (LowLevel.castTo s) + +horSliderNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.HorSlider) +horSliderNew rectangle label = do + s <- LowLevel.sliderCustom + rectangle + label + (Just (\s -> do + bounds <- LowLevel.getRectangle s + drawSlider s Nothing bounds + )) + (Just (LowLevel.defaultCustomWidgetFuncs { LowLevel.handleCustom = (Just handleHover) })) + LowLevel.setType s HorSliderType + sliderSetup (safeCast s) + return (LowLevel.castTo s) + +fillSliderNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.FillSlider) +fillSliderNew rectangle label = do + s <- LowLevel.sliderCustom + rectangle + label + (Just (\s -> do + bounds <- LowLevel.getRectangle s + drawSlider s Nothing bounds + )) + (Just (LowLevel.defaultCustomWidgetFuncs { LowLevel.handleCustom = (Just handleHover) })) + LowLevel.setType s VertFillSliderType + sliderSetup (safeCast s) + return (LowLevel.castTo s) + +horFillSliderNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.HorFillSlider) +horFillSliderNew rectangle label = do + s <- LowLevel.sliderCustom + rectangle + label + (Just (\s -> do + bounds <- LowLevel.getRectangle s + drawSlider s Nothing bounds + )) + (Just (LowLevel.defaultCustomWidgetFuncs { LowLevel.handleCustom = (Just handleHover) })) + sliderSetup (safeCast s) + LowLevel.setType s HorFillSliderType + return (LowLevel.castTo s) + +horNiceSliderNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.HorNiceSlider) +horNiceSliderNew rectangle label = do + s <- LowLevel.sliderCustom + rectangle + label + (Just (\s -> do + bounds <- LowLevel.getRectangle s + drawSlider s Nothing bounds + )) + (Just (LowLevel.defaultCustomWidgetFuncs { LowLevel.handleCustom = (Just handleHover) })) + sliderSetup (safeCast s) + LowLevel.setType s HorNiceSliderType + return (LowLevel.castTo s) diff --git a/src/Graphics/UI/FLTK/Theme/Light/Spinner.hs b/src/Graphics/UI/FLTK/Theme/Light/Spinner.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/FLTK/Theme/Light/Spinner.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE RecursiveDo, ImplicitParams, ScopedTypeVariables, OverloadedStrings #-} +module Graphics.UI.FLTK.Theme.Light.Spinner + ( + spinnerNew, + -- * Spinner drawing and handling helpers + handleSpinner, + resizeSpinner, + spinnerComponentBounds, + spinnerDownCallback, + spinnerInputCallback, + spinnerUpCallback + ) +where +import Control.Exception +import Graphics.UI.FLTK.LowLevel.Dispatch +import Graphics.UI.FLTK.LowLevel.Fl_Enumerations +import Graphics.UI.FLTK.LowLevel.Fl_Types +import Graphics.UI.FLTK.Theme.Light.Button +import Graphics.UI.FLTK.Theme.Light.Common +import Graphics.UI.FLTK.Theme.Light.Input +import qualified Data.Text as T +import qualified Data.Text.Read as T +import qualified Graphics.UI.FLTK.LowLevel.FL as FL +import qualified Graphics.UI.FLTK.LowLevel.FLTKHS as LowLevel +import Graphics.UI.FLTK.Theme.Light.Assets + +doublePrecisionFormat :: T.Text +doublePrecisionFormat = T.pack "%.*" + +spinnerComponentBounds :: Rectangle -> (Rectangle,Rectangle,Rectangle) +spinnerComponentBounds rect = + let (x',y',w',h') = fromRectangle rect + buttonH = h' `intDiv` 2 + inputW = w' - buttonH - 2 + buttonW = buttonH + 2 + in + ( + toRectangle (x',y',inputW,h'), + toRectangle (x'+inputW,y',buttonW,buttonH), + toRectangle (x'+inputW,y'+ buttonH,buttonW,buttonH) + ) + +handleSpinner :: Ref LowLevel.Input -> Ref LowLevel.Spinner -> Event -> IO (Either UnknownEvent ()) +handleSpinner i s e = + let upOrDown = do + key <- FL.eventKey + case key of + SpecialKeyType Kb_Up -> spinnerUpCallback s i >> return (Right ()) + SpecialKeyType Kb_Down -> spinnerDownCallback s i >> return (Right ()) + _ -> return (Right ()) + in + case e of + Keydown -> upOrDown + Shortcut -> upOrDown + _ -> LowLevel.handleSuper (safeCast s :: Ref LowLevel.Group) e + +updateInput :: Maybe T.Text -> Double -> Ref LowLevel.Input -> IO () +updateInput format v i = + let vString = + case format of + Just f -> if (doublePrecisionFormat `T.isPrefixOf` f) then show v else show (truncate v) + Nothing -> show (truncate v) + in LowLevel.setValue i (T.pack vString) >> return () + +resizeSpinner :: Ref LowLevel.Input -> Ref LowLevel.Button -> Ref LowLevel.Button -> Ref LowLevel.Spinner -> Rectangle -> IO () +resizeSpinner i up down s r = do + LowLevel.resizeSuper (safeCast s :: Ref LowLevel.Group) r + let (iRect,upRect,downRect) = spinnerComponentBounds r + LowLevel.resize i iRect + LowLevel.resize up upRect + LowLevel.resize down downRect + +spinnerInputCallback :: Ref LowLevel.Spinner -> Ref LowLevel.Input -> IO () +spinnerInputCallback s i = do + vString <- LowLevel.getValue i + (vs :: Double) <- + case (T.decimal vString) of + Left _ -> + case (T.double vString) of + Left _ -> throwIO + (userError + ("The contents of the spinner input must be an integer or floating point number: "++ (show (T.unpack vString)))) + Right (v,_) -> return v + Right (v,_) -> return (fromIntegral v) + min <- LowLevel.getMinimum s + max <- LowLevel.getMaximum s + f <- LowLevel.getFormat s + let v = + if (vs < min) + then min + else if (vs > max) + then max + else vs + LowLevel.setValue s v + updateInput f v i + LowLevel.setChanged s + LowLevel.doCallback s + +spinnerUpCallback :: Ref LowLevel.Spinner -> Ref LowLevel.Input -> IO () +spinnerUpCallback s i = do + vi <- LowLevel.getValue s + min <- LowLevel.getMinimum s + max <- LowLevel.getMaximum s + step <- LowLevel.getStep s + wrap <- LowLevel.getWrap s + f <- LowLevel.getFormat s + let v = + let tmp = vi + step + in + if (tmp > max) + then if wrap then min else max + else tmp + LowLevel.setValue s v + updateInput f v i + LowLevel.setChanged s + LowLevel.doCallback s + +spinnerDownCallback :: Ref LowLevel.Spinner -> Ref LowLevel.Input -> IO () +spinnerDownCallback s i = do + vi <- LowLevel.getValue s + min <- LowLevel.getMinimum s + max <- LowLevel.getMaximum s + step <- LowLevel.getStep s + wrap <- LowLevel.getWrap s + let v = + let tmp = vi - step + in + if (tmp < min) + then if wrap then max else min + else tmp + LowLevel.setValue s v + f <- LowLevel.getFormat s + updateInput f v i + LowLevel.setChanged s + LowLevel.doCallback s + +spinnerNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.Spinner) +spinnerNew rect l = mdo + s <- LowLevel.spinnerCustom rect l Nothing + (Just (LowLevel.defaultCustomWidgetFuncs + { + LowLevel.handleCustom = Just (handleSpinner i), + LowLevel.resizeCustom = Just (resizeSpinner i upButton downButton) + })) + LowLevel.setColor s lightBackground + LowLevel.setBox s BorderBox + LowLevel.setTextfont s commonFont + LowLevel.setTextsize s commonFontSize + color <- commonSelectionColor + LowLevel.setSelectionColor s color + LowLevel.setLabelfont s commonFont + LowLevel.setLabelsize s commonFontSize + cs <- LowLevel.getArray s + mapM_ LowLevel.hide cs + numChildren <- LowLevel.children s + mapM_ (LowLevel.removeIndex s . AtIndex) [0 .. numChildren-1] + let (inputRect,upRect,downRect) = spinnerComponentBounds rect + LowLevel.begin s + i <- inputNew inputRect Nothing Nothing + LowLevel.setValue i "1" + LowLevel.setInputType i LowLevel.FlIntInput + LowLevel.setWhen i [WhenEnterKey, WhenRelease] + LowLevel.setCallback i (spinnerInputCallback s) + upButton <- LowLevel.buttonCustom + upRect + Nothing + (Just (\b -> do + spec <- buttonFillSpec b + r <- LowLevel.getRectangle b + s <- LowLevel.getDataSize upSmallImage + drawRegularButton (spec { fillCornerRadius = 0 }) b + LowLevel.draw upSmallImage (centerInRectangle r s))) + Nothing + buttonSetup upButton + LowLevel.setCallback upButton (\_ -> spinnerUpCallback s i) + downButton <- LowLevel.buttonCustom + downRect + Nothing + (Just (\b -> do + spec <- buttonFillSpec b + r <- LowLevel.getRectangle b + s <- LowLevel.getDataSize upSmallImage + drawRegularButton (spec { fillCornerRadius = 0 }) b + LowLevel.draw downSmallImage (centerInRectangle r s))) + Nothing + buttonSetup downButton + LowLevel.setCallback downButton (\_ -> spinnerDownCallback s i) + LowLevel.end s + return s diff --git a/src/Graphics/UI/FLTK/Theme/Light/Table.hs b/src/Graphics/UI/FLTK/Theme/Light/Table.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/FLTK/Theme/Light/Table.hs @@ -0,0 +1,131 @@ +{-| +Module: Graphics.UI.FLTK.Theme.Light.Table + +A word on the table widgets, the theme does provide overrides of +[Table](http://hackage.haskell.org/package/fltkhs/docs/Graphics-UI-FLTK-LowLevel-Table.html) +and +[TableRow](http://hackage.haskell.org/package/fltkhs/docs/Graphics-UI-FLTK-LowLevel-TableRow.html) +but they are pretty lowlevel widgets requiring you to supply column\/row\/cell drawing functions. The +functions below draw nicely themed cells and can be passed the Table/TableRow constructors. + +The idea is they are used in the generic table drawing cell function at each drawing context, +something like: + +@ +... +table <- tableRowNew + (Rectangle ...) + (Just "My Table") + Nothing + drawCell + defaultCustomWidgetFuncs + defaultCustomTableFuncs +... + +drawCell :: (?assets :: Assets) => Ref TableRow -> TableContext -> TableCoordinate -> Rectangle -> IO () +drawCell t tcontext ... = + case tcontext of + ContextRowHeader -> do + ... + drawHeader ... + ContextColHeader -> do + ... + drawHeader ... + ContextCell -> do + ... + drawDataCell ... + _ -> return () +@ +-} +{-# LANGUAGE ImplicitParams, OverloadedStrings, AllowAmbiguousTypes, GADTs, CPP, ExistentialQuantification, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, ScopedTypeVariables, UndecidableInstances #-} +module Graphics.UI.FLTK.Theme.Light.Table + ( + drawDataCell, + drawHeader, + drawHeaderWithImage, + tableCustom, + tableRowNew + ) +where +import Graphics.UI.FLTK.LowLevel.Fl_Types +import Graphics.UI.FLTK.Theme.Light.Common +import qualified Data.Text as T +import qualified Graphics.UI.FLTK.LowLevel.FLTKHS as LowLevel +import Graphics.UI.FLTK.LowLevel.Fl_Enumerations +import Graphics.UI.FLTK.Theme.Light.Assets + +drawHeader :: (?assets :: Assets) => Color -> Alignments -> T.Text -> Rectangle -> IO () +drawHeader c labelAlign l rect = do + spec <- fmap (\s -> s { fillCornerRadius = 0 }) (makeFillSpec rect c c) + fillRectangle spec False + borderRectangle spec True False + f <- LowLevel.flcFont + s <- LowLevel.flcSize + LowLevel.flcSetFont commonFont commonFontSize + oldC <- LowLevel.flcColor + LowLevel.flcSetColor blackColor + LowLevel.flcDrawInBox l rect labelAlign Nothing Nothing + LowLevel.flcSetColor oldC + LowLevel.flcSetFont f s + +drawHeaderWithImage :: (LowLevel.Parent a LowLevel.Image, ?assets :: Assets) => Color -> Alignments -> T.Text -> Ref a -> Rectangle -> IO () +drawHeaderWithImage c labelAlign l i rect = do + spec <- fmap (\s -> s { fillCornerRadius = 0 }) (makeFillSpec rect c c) + fillRectangle spec False + borderRectangle spec True False + f <- LowLevel.flcFont + s <- LowLevel.flcSize + LowLevel.flcSetFont commonFont commonFontSize + oldC <- LowLevel.flcColor + LowLevel.flcSetColor blackColor + LowLevel.flcDrawInBoxWithImageReference l rect labelAlign Nothing i Nothing + LowLevel.flcSetColor oldC + LowLevel.flcSetFont f s + +-- | Custom cell drawing function +drawDataCell :: (?assets :: Assets) => Color -> Alignments -> T.Text -> Rectangle -> IO () +drawDataCell c contentsAlign contents rect = do + spec <- fmap (\s -> s { fillCornerRadius = 0 }) (makeFillSpec rect c c) + LowLevel.flcRectfWithColor rect c + f <- LowLevel.flcFont + s <- LowLevel.flcSize + oldC <- LowLevel.flcColor + LowLevel.flcSetFont commonFont commonFontSize + LowLevel.flcSetColor blackColor + let (x,y,w,h) = fromRectangle rect + LowLevel.flcDrawInBox contents (toRectangle (x+1,y+1,w-2,h-2)) contentsAlign Nothing Nothing + LowLevel.flcRectWithColor rect (fillBorderColor spec) + LowLevel.flcSetColor oldC + LowLevel.flcSetFont f s + +tableCustom :: Rectangle -- ^ Bounds of this table + -> Maybe T.Text -- ^ Optional label + -> Maybe (Ref LowLevel.Table -> IO ()) -- ^ Optional custom table drawing function + -> (Ref LowLevel.Table -> TableContext -> LowLevel.TableCoordinate -> Rectangle -> IO ()) -- ^ Custom table cell drawing function + -> LowLevel.CustomWidgetFuncs LowLevel.Table -- ^ Widget overrides + -> LowLevel.CustomTableFuncs LowLevel.Table -- ^ Table overrides + -> IO (Ref LowLevel.Table) +tableCustom rectangle label' draw'' drawCell' customWidgetFuncs' customTableFuncs' = do + t <- LowLevel.tableCustom rectangle label' draw'' drawCell' customWidgetFuncs' customTableFuncs' + c <- commonColor + LowLevel.setColor t lightBackground + LowLevel.setColHeaderColor t c + LowLevel.setRowHeaderColor t c + commonFillColor >>= LowLevel.setSelectionColor t + return t + +tableRowNew :: Rectangle -- ^ Bounds of this table + -> Maybe T.Text -- ^ Optional label + -> Maybe (Ref LowLevel.TableRow -> IO ()) -- ^ Optional custom table drawing function + -> (Ref LowLevel.TableRow -> TableContext -> LowLevel.TableCoordinate -> Rectangle -> IO ()) -- ^ Custom table cell drawing function + -> LowLevel.CustomWidgetFuncs LowLevel.TableRow -- ^ Widget overrides + -> LowLevel.CustomTableFuncs LowLevel.TableRow -- ^ Table overrides + -> IO (Ref LowLevel.TableRow) +tableRowNew rectangle label' draw'' drawCell' customWidgetFuncs' customTableFuncs' = do + t <- LowLevel.tableRowNew rectangle label' draw'' drawCell' customWidgetFuncs' customTableFuncs' + c <- commonColor + LowLevel.setColor t lightBackground + LowLevel.setColHeaderColor t c + LowLevel.setRowHeaderColor t c + commonFillColor >>= LowLevel.setSelectionColor t + return t diff --git a/src/Graphics/UI/FLTK/Theme/Light/Tabs.hs b/src/Graphics/UI/FLTK/Theme/Light/Tabs.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/FLTK/Theme/Light/Tabs.hs @@ -0,0 +1,402 @@ +{-# LANGUAGE ImplicitParams, OverloadedStrings, AllowAmbiguousTypes, GADTs, CPP, ExistentialQuantification, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, ScopedTypeVariables, UndecidableInstances #-} +module Graphics.UI.FLTK.Theme.Light.Tabs + ( + tabsNew, + -- * Tab Helpers and Handlers + TabSpec(..), + drawTabs, + lightTabClientAreaCustom, + lightTabHandleCustom, + lightTabHeightCustom, + lightTabPositionsCustom, + lightTabRedrawTabs, + lightTabWhichCustom + ) +where +import Control.Monad +import Data.IORef +import Data.List +import Graphics.UI.FLTK.LowLevel.Dispatch (safeCast) +import Graphics.UI.FLTK.LowLevel.Fl_Enumerations +import Graphics.UI.FLTK.LowLevel.Fl_Types +import Graphics.UI.FLTK.Theme.Light.Common +import qualified Data.Text as T +import qualified Graphics.UI.FLTK.LowLevel.FL as FL +import qualified Graphics.UI.FLTK.LowLevel.FLTKHS as LowLevel +import Graphics.UI.FLTK.Theme.Light.Assets + +-- | Visual properties of tabs +data TabSpec = + TabSpec + { + tabRadius :: Int, -- ^ The corner radius of each tab + tabHorizontalPadding :: Int, -- ^ Left\/right padding between a tab edge and its label + tabVerticalPadding :: Int, -- ^ Top\/bottom padding between a tab edge and its label + tabInactiveBorderColor :: Color, -- ^ Color of tabs not currently in focus + tabBorderColor :: Color, -- ^ Border color of active tab + tabFillColor :: Color, + tabViewOffset :: IORef Int, -- ^ Location of the left edge of a tab relative to left edge of the widget itself. + tabPartiallyVisible :: Int + } + +-- | Custom tab drawing function +drawTabs :: TabSpec -> Ref LowLevel.Tabs -> IO () +drawTabs spec t = do + bounds <- LowLevel.getRectangle t + (selectedMaybe, _,widths) <- lightTabPositionsCustom spec t + when (not (null widths)) $ do + (Height tabHeight) <- lightTabHeightCustom spec t + offset <- readIORef (tabViewOffset spec) + let Rectangle (Position (X tabsX) (Y tabsY)) (Size (Width tabsWidth) (Height tabsHeight)) = bounds + (AtIndex tabSelectedIndex) = maybe (AtIndex 0) id selectedMaybe + offsetWidths = map (\(X x,Width w) -> (X (x+offset), Width w)) widths + (X tabSelectedX, Width tabSelectedWidth) = offsetWidths !! tabSelectedIndex + oldShortcut <- LowLevel.flcDrawShortcut + oldColor <- LowLevel.flcColor + LowLevel.flcSetDrawShortcut (Just NormalDrawShortcut) + cs <- LowLevel.getArray t + damages <- LowLevel.getDamage t + when (elem DamageAll damages || elem DamageScroll damages) + (let (X leftMostX,_) = head offsetWidths + rightMostX = let (X rightX, Width w) = last offsetWidths in rightX + w + indexedWidths = zip (map AtIndex [0 ..]) offsetWidths + tabBorder yOffset openBorder = do + LowLevel.flcPushClip (Rectangle (Position (X tabsX) yOffset) (Size (Width tabsWidth) (Height tabsHeight))) + LowLevel.flcBeginLine + LowLevel.flcVertex (toPrecisePosition (Position (X leftMostX) yOffset)) + LowLevel.flcVertex (toPrecisePosition (Position (X tabSelectedX) yOffset)) + LowLevel.flcEndLine + LowLevel.flcBeginLine + LowLevel.flcVertex (toPrecisePosition (Position (X (tabSelectedX + tabSelectedWidth)) yOffset)) + let tabsEnd = if (tabsX + tabsWidth < rightMostX) then tabsX + tabsWidth else rightMostX + LowLevel.flcVertex (toPrecisePosition (Position (X (tabsX+tabsWidth)) yOffset)) + LowLevel.flcEndLine + LowLevel.flcPopClip + let widgetBorder = + case openBorder of + OpenBorderTop -> + Rectangle + (Position (X tabsX) (Y (tabsY+tabHeight))) + (Size (Width tabsWidth) (Height (tabsHeight-(abs tabHeight)))) + OpenBorderBottom -> + Rectangle + (Position (X tabsX) (Y tabsY)) + (Size (Width tabsWidth) (Height (tabsHeight-(abs tabHeight)))) + LowLevel.flcBeginLine + mapM_ (LowLevel.flcVertex . toPrecisePosition) (roundedBoxPoints widgetBorder Nothing (Just openBorder)) + LowLevel.flcEndLine + drawTab openBorder yOffset (AtIndex i, (X tabX,Width tabWidth)) = do + let tabPosition = Position (X tabX) yOffset + tabRectangle = Rectangle tabPosition (Size (Width tabWidth) (Height (abs tabHeight))) + oldColor <- LowLevel.flcColor + -- blank it out first + drawBorderBox t + (BorderBoxSpec + { + borderBoxBounds = tabRectangle, + borderBoxFocusedColor = tabFillColor spec, + borderBoxHoveringColor = tabFillColor spec, + borderBoxColor = tabFillColor spec, + borderBoxFillColor = tabFillColor spec + }) + True + if (i == tabSelectedIndex) then + LowLevel.flcSetColor (tabBorderColor spec) + else LowLevel.flcSetColor (tabInactiveBorderColor spec) + LowLevel.flcBeginLine + mapM_ (LowLevel.flcVertex . toPrecisePosition) (roundedBoxPoints tabRectangle (Just (tabRadius spec)) (Just openBorder)) + LowLevel.flcEndLine + let widget = cs !! i + oldLabeltype <- LowLevel.getLabeltype widget + case oldLabeltype of { NoLabelType -> LowLevel.setLabeltype widget NormalLabelType ResolveImageLabelDoNothing; _ -> return () } + tabAlign <- LowLevel.getTabAlign t + LowLevel.drawLabel widget (Just (tabRectangle, Alignments [tabAlign])) + LowLevel.setLabeltype widget oldLabeltype ResolveImageLabelDoNothing + LowLevel.flcSetColor oldColor + in + if (tabHeight < 0) + then do + oldColor <- LowLevel.flcColor + let yOffset = tabsY + tabsHeight - (abs tabHeight) + LowLevel.flcPushClip (toRectangle (tabsX,yOffset,tabsWidth,abs tabHeight)) + mapM_ (drawTab OpenBorderTop (Y yOffset)) indexedWidths + LowLevel.flcPopClip + LowLevel.flcSetColor (tabBorderColor spec) + tabBorder (Y yOffset) OpenBorderBottom + LowLevel.flcSetColor oldColor + else do + oldColor <- LowLevel.flcColor + LowLevel.flcPushClip (toRectangle (tabsX,tabsY,tabsWidth,tabHeight)) + mapM_ (drawTab OpenBorderBottom (Y tabsY)) indexedWidths + LowLevel.flcPopClip + LowLevel.flcSetColor (tabBorderColor spec) + tabBorder (Y (tabsY + tabHeight)) OpenBorderTop + LowLevel.flcSetColor oldColor) + if (elem DamageAll damages) + then LowLevel.drawChild t (cs !! tabSelectedIndex) + else LowLevel.updateChild t (cs !! tabSelectedIndex) + LowLevel.flcSetColor oldColor + LowLevel.flcSetDrawShortcut oldShortcut + +-- | Damage the tabs widget appropriately for redraw +lightTabRedrawTabs :: TabSpec -> Ref LowLevel.Tabs -> IO () +lightTabRedrawTabs spec t = do + bounds <- LowLevel.getRectangle t + let (tabsX,tabsY,tabsWidth,tabsHeight) = fromRectangle bounds + (Height tabHeight) <- LowLevel.tabHeight t + LowLevel.setDamageInside t [DamageScroll] + (if (tabHeight < 0) + then toRectangle (tabsX,tabsY+tabsHeight-(abs tabHeight),tabsWidth,(abs tabHeight)) + else toRectangle (tabsX,tabsY,tabsWidth,tabHeight)) + +-- | Handles all events to the tab +lightTabHandleCustom :: TabSpec -> Ref LowLevel.Tabs -> Event -> IO (Either UnknownEvent ()) +lightTabHandleCustom spec t e = do + tl <- LowLevel.getLabel t + bounds <- LowLevel.getRectangle t + let (tabsX,tabsY,tabsWidth,tabsHeight) = fromRectangle bounds + offset <- readIORef (tabViewOffset spec) + pos@(Position (X x') (Y y')) <- FL.eventPosition + nextIndexAndWidget <- lightTabWhichCustom spec t pos + (_,_,widths) <- lightTabPositionsCustom spec t + let nextWidget = fmap (\(_,w) -> w) nextIndexAndWidget + nextIndex = fmap (\(i,_) -> i) nextIndexAndWidget + setSelectedWidget = LowLevel.setPush t nextWidget >> return (Right ()) + offsetWidths = map (\(X x, Width w) -> (X (x+offset), Width w)) widths + adjustOffset newOffset = writeIORef (tabViewOffset spec) (offset-newOffset) + partiallyShow i = + let (_,Width w) = offsetWidths !! i in + if (w >= (tabPartiallyVisible spec)) + then (tabPartiallyVisible spec) + else w + handleRelease = do + tabBarRect <- tabBarRectangle spec t + if (not (insideRectangle pos tabBarRect)) + then LowLevel.handleSuper t e + else do + lastSelected <- LowLevel.getPush t + LowLevel.setPush t (Nothing :: (Maybe (Ref LowLevel.Widget))) + focusedWidget <- FL.focus + case lastSelected of + Nothing -> return (Right ()) + Just w -> do + vf <- FL.visibleFocus + when vf + (do + imFocused <- refPtrEquals w t + if imFocused then lightTabRedrawTabs spec t + else FL.setFocus(t) >> lightTabRedrawTabs spec t) + changed <- LowLevel.setValue t lastSelected + case changed of + Left NoChange -> do + whens <- LowLevel.getWhen t + when (WhenNotChanged `elem` whens) (LowLevel.setChanged t >> LowLevel.doCallback t) + Right () -> LowLevel.setChanged t >> LowLevel.doCallback t + deleted <- isNull w + if (not deleted) + then LowLevel.tooltipSetCurrent (Just w) >> return (Right()) + else return (Right ()) + handlePush = + let adjustWhenNot yOutsideRange = + if yOutsideRange then LowLevel.handleSuper (safeCast t :: Ref LowLevel.Group) e + else + case nextIndex of + Just (AtIndex i) -> + let (X x, Width w) = offsetWidths !! i + rightOverflow = (x+w) - (tabsX+tabsWidth) + leftOverflow = x-tabsX + in do + case i of + _ | i == 0 -> adjustOffset leftOverflow + | i == (length widths - 1) -> adjustOffset (if (rightOverflow < 0) then 0 else rightOverflow) + | otherwise -> + if (rightOverflow >= 0) + then adjustOffset (rightOverflow + partiallyShow (i+1)) + else if (leftOverflow < 0) + then adjustOffset (leftOverflow - partiallyShow (i-1)) + else return () + setSelectedWidget + _ -> setSelectedWidget + in do + (Height tabHeight) <- LowLevel.tabHeight t + if (tabHeight < 0) + then adjustWhenNot (y' < tabsY + tabsHeight - (abs tabHeight)) + else adjustWhenNot (y' > tabsY + tabHeight) + + case e of + Push -> handlePush + Drag -> handleRelease + Release -> handleRelease + Keydown -> do + (selectedMaybe,_,widths) <- lightTabPositionsCustom spec t + eventKey <- FL.eventKey + case eventKey of + SpecialKeyType Kb_Left -> + case selectedMaybe of + Just (AtIndex i) -> + if (i == 0) then LowLevel.handleSuper t e + else + let (X x, Width w) = offsetWidths !! (i-1) + currOffset = x - tabsX + in do + if (currOffset >= 0) + then return () + else adjustOffset (currOffset - (if (i > 1) then partiallyShow (i-2) else 0)) + LowLevel.handleSuper t e + _ -> LowLevel.handleSuper t e + SpecialKeyType Kb_Right -> + case selectedMaybe of + Just (AtIndex i) -> + if (i == ((length widths) - 1)) then LowLevel.handleSuper t e + else + let (X x,Width w) = offsetWidths !! (i+1) + currOffset = (x+w) - (tabsX+tabsWidth) + in do + when (currOffset >= 0) (adjustOffset (currOffset + (if (i < (length widths - 2)) then partiallyShow (i+2) else 0))) + LowLevel.handleSuper t e + _ -> LowLevel.handleSuper t e + _ -> LowLevel.handleSuper t e + _ -> LowLevel.handleSuper t e + +-- | Calculate the width and x coordinate of each tab +lightTabPositionsCustom :: TabSpec -> Ref LowLevel.Tabs -> IO (Maybe AtIndex, Int, [(X,Width)]) +lightTabPositionsCustom spec t = do + bounds <- LowLevel.getRectangle t + cs <- LowLevel.getArray t + let Rectangle (Position (X x) _) _ = bounds + selected <- selectedTab (zip (map AtIndex [0 ..]) cs) + widths <- + mapM + (\c -> do + oldLabeltype <- LowLevel.getLabeltype c + oldAlign <- LowLevel.getAlign c + case oldLabeltype of { NoLabelType -> LowLevel.setLabeltype c NormalLabelType ResolveImageLabelDoNothing; _ -> return () } + (Size (Width width') _) <- LowLevel.measureLabel c Nothing + tabAlign <- LowLevel.getTabAlign t + LowLevel.setAlign c (Alignments [tabAlign]) + LowLevel.setLabeltype c oldLabeltype ResolveImageLabelDoNothing + LowLevel.setAlign c oldAlign + return (width' + (tabHorizontalPadding spec) * 2) + ) + cs + let xOffsets = zip (map X (map ((+) x) (scanl (+) 0 widths))) (map Width widths) + return (selected, (0 :: Int), xOffsets) + where + selectedTab :: [(AtIndex, Ref LowLevel.Widget)] -> IO (Maybe AtIndex) + selectedTab [] = return Nothing + selectedTab ((i,w):ws) = do + v <- LowLevel.getVisible w + if v then return (Just i) else selectedTab ws + +-- | Calculate the height of each tab, a negative height indicates tabs are along the bottom +lightTabHeightCustom :: TabSpec -> Ref LowLevel.Tabs -> IO Height +lightTabHeightCustom spec t = do + cs <- LowLevel.getArray t + if (null cs) + then return (Height 0) + else do + (Y y) <- LowLevel.getY t + (Height h) <- LowLevel.getH t + tops <- mapM (\c -> do {(Y y) <- LowLevel.getY c; return (y+(tabVerticalPadding spec)*2);}) cs + bottoms <- mapM (\c -> do {(Y y) <- LowLevel.getY c; (Height h) <- LowLevel.getH c; return (y+h-(tabVerticalPadding spec)*2);}) cs + let topGap = minimum (map (\cy -> cy - y) tops) + bottomGap = y+h - (maximum bottoms) + height = if (bottomGap > topGap) then + if bottomGap <= 0 then 0 else (-bottomGap) + else if topGap <= 0 then 0 else topGap + return (Height height) + +-- | Calculate the bounds of the area inside the tab containing other widgets +lightTabClientAreaCustom :: TabSpec -> Ref LowLevel.Tabs -> LowLevel.TabsHeightOffset -> IO Rectangle +lightTabClientAreaCustom spec t tOffset = do + cs <- LowLevel.getArray t + case cs of + (c:_) -> LowLevel.getRectangle c + _ -> do + lf <- LowLevel.getLabelfont t + ls <- LowLevel.getLabelsize t + (Height h) <- LowLevel.flcHeightOfFont lf ls + let paddedHeight = h+(tabVerticalPadding spec * 2) + (tabsX,tabsY,tabsW,tabsH) <- fmap fromRectangle (LowLevel.getRectangle t) + let clientArea = case tOffset of + LowLevel.TabsAtTop Nothing -> (tabsX,tabsY+paddedHeight,tabsW,tabsH-paddedHeight) + LowLevel.TabsAtBottom Nothing -> (tabsX,tabsY,tabsW,tabsH-paddedHeight) + LowLevel.TabsAtTop (Just o) -> (tabsX,tabsY+o,tabsW,tabsH-o) + LowLevel.TabsAtBottom (Just o) -> (tabsX,tabsY,tabsW,tabsH-o) + return (toRectangle clientArea) + +-- | Calcuate the bounds of the tab bar +tabBarRectangle :: TabSpec -> Ref LowLevel.Tabs -> IO Rectangle +tabBarRectangle spec t = do + (tabsX,tabsY,tabsW,tabsH) <- fmap fromRectangle (LowLevel.getRectangle t) + (Height tabHeight) <- lightTabHeightCustom spec t + return + (if (tabHeight < 0) + then toRectangle (tabsX,tabsY+tabsH-(abs tabHeight),tabsW,abs tabHeight) + else toRectangle (tabsX,tabsY,tabsW,tabHeight)) + +-- | Determine which tab was just selected +lightTabWhichCustom :: TabSpec -> Ref LowLevel.Tabs -> Position -> IO (Maybe (AtIndex, Ref LowLevel.Widget)) +lightTabWhichCustom spec t pos = do + tabBarRect <- tabBarRectangle spec t + if (not (insideRectangle pos tabBarRect)) + then return Nothing + else do + let (_,tabBarY,_,tabBarHeight) = fromRectangle tabBarRect + (_,_,widths) <- lightTabPositionsCustom spec t + offset <- readIORef (tabViewOffset spec) + let tab = find + (\(i,(x,w)) -> insideRectangle pos (Rectangle (Position x (Y tabBarY)) (Size w (Height tabBarHeight)))) + (zip (map AtIndex [0 ..]) (map (\(X x, Width w) -> (X (x+offset), Width w)) widths)) + cs <- LowLevel.getArray t + return (fmap (\(AtIndex i, _) -> (AtIndex i,cs !! i)) tab) + +-- | A default 'TabSpec' +tabSpec :: (?assets :: Assets) => Rectangle -> IO TabSpec +tabSpec rectangle = do + let (tabsX,tabsY,tabsWidth,tabsHeight) = fromRectangle rectangle + buttonWidth = 15 + buttonHeight = 15 + borderColor <- commonSelectionColor + color <- commonColor + offset <- newIORef 0 + return + (TabSpec + { + tabRadius = 1 + , tabHorizontalPadding = 10 + , tabVerticalPadding = 3 + , tabInactiveBorderColor = colorAverage color blackColor 0.97 + , tabBorderColor = borderColor + , tabFillColor = lightBackground + , tabViewOffset = offset + , tabPartiallyVisible = 20 + }) + +tabsNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.Tabs) +tabsNew rectangle label = do + spec <- tabSpec rectangle + t <- LowLevel.tabsCustom + rectangle + label + (Just + (LowLevel.CustomTabFuncs + { + LowLevel.tabDrawCustom = drawTabs spec + , LowLevel.tabPositionsCustom = lightTabPositionsCustom spec + , LowLevel.tabHeightCustom = lightTabHeightCustom spec + , LowLevel.tabWhichCustom = lightTabWhichCustom spec + , LowLevel.tabRedrawTabs = lightTabRedrawTabs spec + , LowLevel.tabClientArea = lightTabClientAreaCustom spec + })) + (Just + (LowLevel.defaultCustomWidgetFuncs + { + LowLevel.handleCustom = Just (lightTabHandleCustom spec) + })) + p <- LowLevel.getParent t + color <- maybe (return lightBackground) LowLevel.getColor p + LowLevel.setColor t color + LowLevel.setLabelfont t commonFont + LowLevel.setLabelsize t commonFontSize + return t diff --git a/src/Graphics/UI/FLTK/Theme/Light/TextDisplay.hs b/src/Graphics/UI/FLTK/Theme/Light/TextDisplay.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/FLTK/Theme/Light/TextDisplay.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE ImplicitParams, OverloadedStrings #-} +module Graphics.UI.FLTK.Theme.Light.TextDisplay + ( + textDisplayNew + ) +where +import Graphics.UI.FLTK.Theme.Light.Common +import qualified Graphics.UI.FLTK.LowLevel.FLTKHS as LowLevel +import qualified Data.Text as T +import Graphics.UI.FLTK.Theme.Light.Assets + +textDisplayNew :: (?assets :: Assets) => LowLevel.Rectangle -> Maybe T.Text -> IO (LowLevel.Ref LowLevel.TextDisplay) +textDisplayNew r l = do + t <- LowLevel.textDisplayNew r l + LowLevel.setColor t lightBackground + LowLevel.setTextfont t commonFont + LowLevel.setTextsize t commonFontSize + color <- commonSelectionColor + LowLevel.setSelectionColor t color + LowLevel.setLabelfont t commonFont + LowLevel.setLabelsize t commonFontSize + return t diff --git a/src/Graphics/UI/FLTK/Theme/Light/TextEditor.hs b/src/Graphics/UI/FLTK/Theme/Light/TextEditor.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/FLTK/Theme/Light/TextEditor.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE ImplicitParams, OverloadedStrings #-} +module Graphics.UI.FLTK.Theme.Light.TextEditor + ( + textEditorNew + ) +where +import Graphics.UI.FLTK.Theme.Light.Common +import qualified Graphics.UI.FLTK.LowLevel.FLTKHS as LowLevel +import qualified Data.Text as T +import Graphics.UI.FLTK.Theme.Light.Assets + +textEditorNew :: (?assets :: Assets) => LowLevel.Rectangle -> Maybe T.Text -> IO (LowLevel.Ref LowLevel.TextEditor) +textEditorNew r l = do + t <- LowLevel.textEditorNew r l + LowLevel.setColor t lightBackground + LowLevel.setTextfont t commonFont + LowLevel.setTextsize t commonFontSize + color <- commonSelectionColor + LowLevel.setSelectionColor t color + LowLevel.setLabelfont t commonFont + LowLevel.setLabelsize t commonFontSize + return t diff --git a/src/Graphics/UI/FLTK/Theme/Light/Tree.hs b/src/Graphics/UI/FLTK/Theme/Light/Tree.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/FLTK/Theme/Light/Tree.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE ImplicitParams, OverloadedStrings, AllowAmbiguousTypes, GADTs, CPP, ExistentialQuantification, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, ScopedTypeVariables, UndecidableInstances #-} +module Graphics.UI.FLTK.Theme.Light.Tree + ( + treeNew + ) +where +import Graphics.UI.FLTK.LowLevel.Fl_Enumerations +import Graphics.UI.FLTK.LowLevel.Fl_Types +import Graphics.UI.FLTK.Theme.Light.Common +import qualified Data.Text as T +import qualified Graphics.UI.FLTK.LowLevel.FLTKHS as LowLevel +import Graphics.UI.FLTK.Theme.Light.Assets + +treeNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.Tree) +treeNew rectangle l' = do + let customDraw :: Ref LowLevel.Tree -> IO () + customDraw t = do + (color :: Color) <- LowLevel.getColor t + let slightlyDarker = colorAverage color blackColor 0.85 + withCustomBoxDraw + BorderBox + (\rect _ -> do + LowLevel.flcRectfWithColor rect color + LowLevel.flcRectWithColor rect slightlyDarker) + (LowLevel.drawSuper t) + t <- LowLevel.treeCustom rectangle l' (Just customDraw) Nothing + LowLevel.setBox t BorderBox + LowLevel.setColor t lightBackground + LowLevel.setLabelfont t commonFont + LowLevel.setLabelsize t commonFontSize + LowLevel.setItemLabelfont t commonFont + LowLevel.setItemLabelsize t commonFontSize + sc <- commonSelectionColor + LowLevel.setSelectionColor t sc + LowLevel.setScrollbarSize t 10 + LowLevel.setConnectorstyle t TreeConnectorSolid + return t diff --git a/src/Graphics/UI/FLTK/Theme/Light/Valuator.hs b/src/Graphics/UI/FLTK/Theme/Light/Valuator.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/FLTK/Theme/Light/Valuator.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE ImplicitParams, OverloadedStrings, AllowAmbiguousTypes, GADTs, CPP, ExistentialQuantification, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, ScopedTypeVariables, UndecidableInstances #-} +module Graphics.UI.FLTK.Theme.Light.Valuator + ( + adjusterNew, + valueOutputNew, + valueInputNew + ) +where +import Graphics.UI.FLTK.LowLevel.Fl_Enumerations +import Graphics.UI.FLTK.LowLevel.Fl_Types +import Graphics.UI.FLTK.Theme.Light.Common +import Graphics.UI.FLTK.Theme.Light.Input +import qualified Data.Text as T +import qualified Graphics.UI.FLTK.LowLevel.FL as FL +import qualified Graphics.UI.FLTK.LowLevel.FLTKHS as LowLevel +import Graphics.UI.FLTK.LowLevel.Dispatch +import Graphics.UI.FLTK.Theme.Light.Assets + +adjusterNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.Adjuster) +adjusterNew rectangle label = do + a <- LowLevel.adjusterNew rectangle label + LowLevel.setLabelfont a commonFont + LowLevel.setLabelsize a commonFontSize + color <- commonColor + LowLevel.setColor a color + color <- commonSelectionColor + LowLevel.setSelectionColor a color + return a + +valueOutputNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.ValueOutput) +valueOutputNew rect l = do + let customDraw :: Ref LowLevel.ValueOutput -> IO () + customDraw vo = + withCustomBoxDraw + BorderBox + (\rect color -> do + LowLevel.flcRectfWithColor rect color + focused <- isWidget vo FL.focus + inputBox focused rect color) + (LowLevel.drawSuper vo) + vo <- LowLevel.valueOutputCustom rect l (Just customDraw) Nothing + LowLevel.setColor vo lightBackground + LowLevel.setBox vo BorderBox + LowLevel.setTextfont vo commonFont + LowLevel.setTextsize vo commonFontSize + color <- commonSelectionColor + LowLevel.setSelectionColor vo color + LowLevel.setLabelfont vo commonFont + LowLevel.setLabelsize vo commonFontSize + return vo + +valueInputNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.ValueInput) +valueInputNew rect l = do + let customDraw :: Ref LowLevel.ValueInput -> IO () + customDraw vi = + withCustomBoxDraw + BorderBox + (\rect color -> do + LowLevel.flcRectfWithColor rect color + focused <- isWidget vi FL.focus + inputBox focused rect color) + (LowLevel.drawSuper vi) + vi <- LowLevel.valueInputCustom rect l (Just customDraw) Nothing + LowLevel.setColor vi lightBackground + LowLevel.setBox vi BorderBox + LowLevel.setTextfont vi commonFont + LowLevel.setTextsize vi commonFontSize + color <- commonSelectionColor + LowLevel.setSelectionColor vi color + LowLevel.setLabelfont vi commonFont + LowLevel.setLabelsize vi commonFontSize + return vi diff --git a/src/Graphics/UI/FLTK/Theme/Light/Window.hs b/src/Graphics/UI/FLTK/Theme/Light/Window.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/FLTK/Theme/Light/Window.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE ImplicitParams, OverloadedStrings, AllowAmbiguousTypes, GADTs, CPP, ExistentialQuantification, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, ScopedTypeVariables, UndecidableInstances #-} +module Graphics.UI.FLTK.Theme.Light.Window + ( + doubleWindowNew, + singleWindowNew, + windowNew + ) +where +import Graphics.UI.FLTK.LowLevel.Fl_Types +import Graphics.UI.FLTK.Theme.Light.Common +import qualified Data.Text as T +import qualified Graphics.UI.FLTK.LowLevel.FLTKHS as LowLevel + +windowNew :: Size -> Maybe Position -> Maybe T.Text -> IO (Ref LowLevel.Window) +windowNew size position label = do + w <- LowLevel.windowNew size position label + LowLevel.setColor w lightBackground + return w + +doubleWindowNew :: Size -> Maybe Position -> Maybe T.Text -> IO (Ref LowLevel.DoubleWindow) +doubleWindowNew size position label = do + w <- LowLevel.doubleWindowNew size position label + LowLevel.setColor w lightBackground + return w + +singleWindowNew :: Size -> Maybe Position -> Maybe T.Text -> IO (Ref LowLevel.SingleWindow) +singleWindowNew size position label = do + w <- LowLevel.singleWindowNew size position label + LowLevel.setColor w lightBackground + return w diff --git a/src/Graphics/UI/FLTK/Theme/Light/Wizard.hs b/src/Graphics/UI/FLTK/Theme/Light/Wizard.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/FLTK/Theme/Light/Wizard.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE ImplicitParams, OverloadedStrings #-} +module Graphics.UI.FLTK.Theme.Light.Wizard + ( + wizardNew + ) +where +import Graphics.UI.FLTK.Theme.Light.Common +import Graphics.UI.FLTK.Theme.Light.Assets +import qualified Graphics.UI.FLTK.LowLevel.FLTKHS as LowLevel +import qualified Data.Text as T + +wizardNew :: (?assets :: Assets) => LowLevel.Rectangle -> Maybe T.Text -> IO (LowLevel.Ref LowLevel.Wizard) +wizardNew r l = do + w <- LowLevel.wizardNew r l + LowLevel.setColor w lightBackground + color <- commonSelectionColor + LowLevel.setSelectionColor w color + LowLevel.setLabelfont w commonFont + LowLevel.setLabelsize w commonFontSize + return w