Chart-fltkhs (empty) → 0.1.0.4
raw patch · 15 files changed
+2330/−0 lines, 15 filesdep +Chartdep +Chart-fltkhsdep +basebuild-type:Customsetup-changed
Dependencies added: Chart, Chart-fltkhs, base, colour, data-default-class, fltkhs, lens, operational, random, text, time, vector
Files
- Chart-fltkhs.cabal +493/−0
- LICENSE +29/−0
- Setup.hs +48/−0
- examples/Example1.hs +82/−0
- examples/Example11.hs +90/−0
- examples/Example12.hs +74/−0
- examples/Example13.hs +117/−0
- examples/Example2.hs +108/−0
- examples/Example3.hs +101/−0
- examples/Example4.hs +98/−0
- examples/Example5.hs +73/−0
- examples/Example7.hs +76/−0
- examples/Example8.hs +81/−0
- examples/Prices.hs +396/−0
- src/Graphics/Rendering/Chart/Backend/FLTKHS.hs +464/−0
+ Chart-fltkhs.cabal view
@@ -0,0 +1,493 @@+cabal-version: 2.4+name: Chart-fltkhs+version: 0.1.0.4+license: BSD-3-Clause+license-file: LICENSE+maintainer: michael.oswald@onikudaki.net+author: Michael Oswald+homepage: https://github.com/oswald2/Chart-fltkhs+synopsis: A backend for the Chart library for FLTKHS+description:+ A backend for the Chart library for FLTKHS, based on FLTKs native drawing functions.+category: Graphics+build-type: Custom++source-repository head+ type: git+ location: http://github.com/oswald2/Chart-fltkhs++custom-setup+ setup-depends: Cabal >=2.2.0.0,+ base >=4.4,+ filepath -any++flag fastcompile+ description:+ Turn off optimizations for faster compilation+ default: False+ manual: True++flag examples+ description:+ Also compile the examples+ default: False+ manual: True++library+ exposed-modules:+ Graphics.Rendering.Chart.Backend.FLTKHS+ hs-source-dirs: src+ default-language: Haskell2010+ other-extensions: OverloadedStrings BangPatterns++ build-depends:+ base ==4.*,+ fltkhs ==0.8.*,+ text >=1.2.2.0 && <1.3,+ vector >=0.12.0.3 && <0.13,+ Chart >=1.9.1 && <1.10,+ operational >=0.2.3.5 && <0.3,+ colour >=2.3.5 && <2.4,+ data-default-class >=0.1.2.0 && <0.2++ if ((impl(ghc >=7.10) && impl(ghc <8.0)) && flag(fastcompile))+ ghc-options: -fno-specialise -fmax-simplifier-iterations=0+ -fsimplifier-phases=0+ else+ ghc-options: -Wall -Wcompat -Widentities+ -Wincomplete-record-updates -Wincomplete-uni-patterns+ -Wredundant-constraints -Wpartial-fields -funbox-strict-fields+++ if os(windows)+ ghc-options: -pgml g++ "-optl-Wl,--allow-multiple-definition"+ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc"+ "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive"++ if os(osx)+ ghc-options: " -optl-Wl,-lfltkc"++ if (!os(osx) && !os(windows))+ ghc-options: -pgml g++ "-optl-Wl,--allow-multiple-definition"+ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc"+ "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive"++executable Example1+ if flag(examples)+ buildable: True+ else+ buildable: False++ main-is: Example1.hs+ hs-source-dirs: examples/+ default-language: Haskell2010+ ghc-options: -threaded+ build-depends:+ base ==4.*,+ fltkhs >=0.8.0.2 && <0.9,+ text >=1.2.2.0 && <1.3,+ vector >=0.12.0.3 && <0.13,+ lens >=4.17.1 && <4.18,+ Chart >=1.9.1 && <1.10,+ colour >=2.3.5 && <2.4,+ data-default-class >=0.1.2.0 && <0.2,+ Chart-fltkhs -any++ if ((impl(ghc >=7.10) && impl(ghc <8.0)) && flag(fastcompile))+ ghc-options: -fno-specialise -fmax-simplifier-iterations=0+ -fsimplifier-phases=0+ else+ ghc-options:++ if os(windows)+ ghc-options: -pgml g++ "-optl-Wl,--allow-multiple-definition"+ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc"+ "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive"++ if os(osx)+ ghc-options: "-optl-Wl,-lfltkc"++ if (!os(osx) && !os(windows))+ ghc-options: -pgml g++ "-optl-Wl,--allow-multiple-definition"+ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc"+ "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive"++++executable Example2+ if flag(examples)+ buildable: True+ else+ buildable: False++ main-is: Example2.hs+ hs-source-dirs: examples/+ other-modules:+ Prices+ default-language: Haskell2010+ ghc-options: -threaded+ build-depends:+ base ==4.*,+ fltkhs >=0.8.0.2 && <0.9,+ text >=1.2.2.0 && <1.3,+ vector >=0.12.0.3 && <0.13,+ time >=1.8.0.2 && <1.9,+ lens >=4.17.1 && <4.18,+ Chart >=1.9.1 && <1.10,+ colour >=2.3.5 && <2.4,+ data-default-class >=0.1.2.0 && <0.2,+ Chart-fltkhs -any++ if ((impl(ghc >=7.10) && impl(ghc <8.0)) && flag(fastcompile))+ ghc-options: -fno-specialise -fmax-simplifier-iterations=0+ -fsimplifier-phases=0+ else+ ghc-options:++ if os(windows)+ ghc-options: -pgml g++ "-optl-Wl,--allow-multiple-definition"+ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc"+ "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive"++ if os(osx)+ ghc-options: "-optl-Wl,-lfltkc"++ if (!os(osx) && !os(windows))+ ghc-options: -pgml g++ "-optl-Wl,--allow-multiple-definition"+ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc"+ "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive"++executable Example3+ if flag(examples)+ buildable: True+ else+ buildable: False++ main-is: Example3.hs+ hs-source-dirs: examples/+ other-modules:+ Prices+ default-language: Haskell2010+ ghc-options: -threaded+ build-depends:+ base ==4.*,+ fltkhs >=0.8.0.2 && <0.9,+ text >=1.2.2.0 && <1.3,+ vector >=0.12.0.3 && <0.13,+ time >=1.8.0.2 && <1.9,+ lens >=4.17.1 && <4.18,+ Chart >=1.9.1 && <1.10,+ colour >=2.3.5 && <2.4,+ data-default-class >=0.1.2.0 && <0.2,+ Chart-fltkhs -any++ if ((impl(ghc >=7.10) && impl(ghc <8.0)) && flag(fastcompile))+ ghc-options: -fno-specialise -fmax-simplifier-iterations=0+ -fsimplifier-phases=0+ else+ ghc-options:++ if os(windows)+ ghc-options: -pgml g++ "-optl-Wl,--allow-multiple-definition"+ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc"+ "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive"++ if os(osx)+ ghc-options: "-optl-Wl,-lfltkc"++ if (!os(osx) && !os(windows))+ ghc-options: -pgml g++ "-optl-Wl,--allow-multiple-definition"+ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc"+ "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive"++executable Example4+ if flag(examples)+ buildable: True+ else+ buildable: False++ main-is: Example4.hs+ hs-source-dirs: examples/+ default-language: Haskell2010+ ghc-options: -threaded+ build-depends:+ base ==4.*,+ fltkhs >=0.8.0.2 && <0.9,+ text >=1.2.2.0 && <1.3,+ vector >=0.12.0.3 && <0.13,+ lens >=4.17.1 && <4.18,+ Chart >=1.9.1 && <1.10,+ colour >=2.3.5 && <2.4,+ data-default-class >=0.1.2.0 && <0.2,+ Chart-fltkhs -any,+ random ==1.1.*++ if ((impl(ghc >=7.10) && impl(ghc <8.0)) && flag(fastcompile))+ ghc-options: -fno-specialise -fmax-simplifier-iterations=0+ -fsimplifier-phases=0+ else+ ghc-options:++ if os(windows)+ ghc-options: -pgml g++ "-optl-Wl,--allow-multiple-definition"+ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc"+ "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive"++ if os(osx)+ ghc-options: "-optl-Wl,-lfltkc"++ if (!os(osx) && !os(windows))+ ghc-options: -pgml g++ "-optl-Wl,--allow-multiple-definition"+ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc"+ "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive"++executable Example5+ if flag(examples)+ buildable: True+ else+ buildable: False++ main-is: Example5.hs+ hs-source-dirs: examples/+ other-modules:+ Prices+ default-language: Haskell2010+ ghc-options: -threaded+ build-depends:+ base ==4.*,+ fltkhs >=0.8.0.2 && <0.9,+ text >=1.2.2.0 && <1.3,+ vector >=0.12.0.3 && <0.13,+ time >=1.8.0.2 && <1.9,+ lens >=4.17.1 && <4.18,+ Chart >=1.9.1 && <1.10,+ colour >=2.3.5 && <2.4,+ data-default-class >=0.1.2.0 && <0.2,+ Chart-fltkhs -any++ if ((impl(ghc >=7.10) && impl(ghc <8.0)) && flag(fastcompile))+ ghc-options: -fno-specialise -fmax-simplifier-iterations=0+ -fsimplifier-phases=0+ else+ ghc-options:++ if os(windows)+ ghc-options: -pgml g++ "-optl-Wl,--allow-multiple-definition"+ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc"+ "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive"++ if os(osx)+ ghc-options: "-optl-Wl,-lfltkc"++ if (!os(osx) && !os(windows))+ ghc-options: -pgml g++ "-optl-Wl,--allow-multiple-definition"+ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc"+ "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive"++executable Example7+ if flag(examples)+ buildable: True+ else+ buildable: False++ main-is: Example7.hs+ hs-source-dirs: examples/+ default-language: Haskell2010+ ghc-options: -threaded+ build-depends:+ base ==4.*,+ fltkhs >=0.8.0.2 && <0.9,+ text >=1.2.2.0 && <1.3,+ vector >=0.12.0.3 && <0.13,+ lens >=4.17.1 && <4.18,+ Chart >=1.9.1 && <1.10,+ colour >=2.3.5 && <2.4,+ data-default-class >=0.1.2.0 && <0.2,+ Chart-fltkhs -any,+ random ==1.1.*++ if ((impl(ghc >=7.10) && impl(ghc <8.0)) && flag(fastcompile))+ ghc-options: -fno-specialise -fmax-simplifier-iterations=0+ -fsimplifier-phases=0+ else+ ghc-options:++ if os(windows)+ ghc-options: -pgml g++ "-optl-Wl,--allow-multiple-definition"+ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc"+ "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive"++ if os(osx)+ ghc-options: "-optl-Wl,-lfltkc"++ if (!os(osx) && !os(windows))+ ghc-options: -pgml g++ "-optl-Wl,--allow-multiple-definition"+ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc"+ "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive"++executable Example8+ if flag(examples)+ buildable: True+ else+ buildable: False++ main-is: Example8.hs+ hs-source-dirs: examples/+ other-modules:+ Prices+ default-language: Haskell2010+ ghc-options: -threaded+ build-depends:+ base ==4.*,+ fltkhs >=0.8.0.2 && <0.9,+ text >=1.2.2.0 && <1.3,+ vector >=0.12.0.3 && <0.13,+ time >=1.8.0.2 && <1.9,+ lens >=4.17.1 && <4.18,+ Chart >=1.9.1 && <1.10,+ colour >=2.3.5 && <2.4,+ data-default-class >=0.1.2.0 && <0.2,+ Chart-fltkhs -any,+ random ==1.1.*++ if ((impl(ghc >=7.10) && impl(ghc <8.0)) && flag(fastcompile))+ ghc-options: -fno-specialise -fmax-simplifier-iterations=0+ -fsimplifier-phases=0+ else+ ghc-options:++ if os(windows)+ ghc-options: -pgml g++ "-optl-Wl,--allow-multiple-definition"+ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc"+ "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive"++ if os(osx)+ ghc-options: "-optl-Wl,-lfltkc"++ if (!os(osx) && !os(windows))+ ghc-options: -pgml g++ "-optl-Wl,--allow-multiple-definition"+ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc"+ "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive"++executable Example11+ if flag(examples)+ buildable: True+ else+ buildable: False++ main-is: Example11.hs+ hs-source-dirs: examples/+ default-language: Haskell2010+ ghc-options: -threaded+ build-depends:+ base ==4.*,+ fltkhs >=0.8.0.2 && <0.9,+ text >=1.2.2.0 && <1.3,+ vector >=0.12.0.3 && <0.13,+ time >=1.8.0.2 && <1.9,+ lens >=4.17.1 && <4.18,+ Chart >=1.9.1 && <1.10,+ colour >=2.3.5 && <2.4,+ data-default-class >=0.1.2.0 && <0.2,+ Chart-fltkhs -any++ if ((impl(ghc >=7.10) && impl(ghc <8.0)) && flag(fastcompile))+ ghc-options: -fno-specialise -fmax-simplifier-iterations=0+ -fsimplifier-phases=0+ else+ ghc-options:++ if os(windows)+ ghc-options: -pgml g++ "-optl-Wl,--allow-multiple-definition"+ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc"+ "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive"++ if os(osx)+ ghc-options: "-optl-Wl,-lfltkc"++ if (!os(osx) && !os(windows))+ ghc-options: -pgml g++ "-optl-Wl,--allow-multiple-definition"+ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc"+ "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive"++executable Example12+ if flag(examples)+ buildable: True+ else+ buildable: False++ main-is: Example12.hs+ hs-source-dirs: examples/+ default-language: Haskell2010+ ghc-options: -threaded+ build-depends:+ base ==4.*,+ fltkhs >=0.8.0.2 && <0.9,+ text >=1.2.2.0 && <1.3,+ vector >=0.12.0.3 && <0.13,+ time >=1.8.0.2 && <1.9,+ lens >=4.17.1 && <4.18,+ Chart >=1.9.1 && <1.10,+ colour >=2.3.5 && <2.4,+ data-default-class >=0.1.2.0 && <0.2,+ Chart-fltkhs -any++ if ((impl(ghc >=7.10) && impl(ghc <8.0)) && flag(fastcompile))+ ghc-options: -fno-specialise -fmax-simplifier-iterations=0+ -fsimplifier-phases=0+ else+ ghc-options:++ if os(windows)+ ghc-options: -pgml g++ "-optl-Wl,--allow-multiple-definition"+ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc"+ "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive"++ if os(osx)+ ghc-options: "-optl-Wl,-lfltkc"++ if (!os(osx) && !os(windows))+ ghc-options: -pgml g++ "-optl-Wl,--allow-multiple-definition"+ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc"+ "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive"++executable Example13+ if flag(examples)+ buildable: True+ else+ buildable: False++ main-is: Example13.hs+ hs-source-dirs: examples/+ default-language: Haskell2010+ ghc-options: -threaded+ build-depends:+ base ==4.*,+ fltkhs >=0.8.0.2 && <0.9,+ text >=1.2.2.0 && <1.3,+ vector >=0.12.0.3 && <0.13,+ time >=1.8.0.2 && <1.9,+ lens >=4.17.1 && <4.18,+ Chart >=1.9.1 && <1.10,+ colour >=2.3.5 && <2.4,+ data-default-class >=0.1.2.0 && <0.2,+ Chart-fltkhs -any++ if ((impl(ghc >=7.10) && impl(ghc <8.0)) && flag(fastcompile))+ ghc-options: -fno-specialise -fmax-simplifier-iterations=0+ -fsimplifier-phases=0+ else+ ghc-options:++ if os(windows)+ ghc-options: -pgml g++ "-optl-Wl,--allow-multiple-definition"+ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc"+ "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive"++ if os(osx)+ ghc-options: "-optl-Wl,-lfltkc"++ if (!os(osx) && !os(windows))+ ghc-options: -pgml g++ "-optl-Wl,--allow-multiple-definition"+ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc"+ "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive"
+ LICENSE view
@@ -0,0 +1,29 @@+BSD 3-Clause License++Copyright (c) 2019, Michael Oswald+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++2. 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.++3. Neither the name of the copyright holder nor the names of its+ 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 HOLDER 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.
+ Setup.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE CPP #-}+module Main (main) where++import Distribution.Simple+import Distribution.Simple.Program+import Distribution.Simple.LocalBuildInfo+import Distribution.PackageDescription+import System.FilePath+import System.Environment (getEnv, setEnv)+import Distribution.Simple.LocalBuildInfo (installedPkgs)+import Distribution.Simple.PackageIndex (lookupDependency)+import Distribution.Package (Dependency, PackageName)+import Distribution.Version (anyVersion)+import Distribution.System (buildOS, OS(Windows, OSX))+import Distribution.InstalledPackageInfo+import System.IO.Error++#if defined(MIN_VERSION_Cabal) && MIN_VERSION_Cabal(2,0,0)+_PackageName = mkPackageName+#else+_PackageName = PackageName+#endif++main :: IO ()+main = defaultMainWithHooks (simpleUserHooks { buildHook = myBuildHook })++myBuildHook pkg_descr local_bld_info user_hooks bld_flags =+ let fltkhsDependency = lookupDependency (installedPkgs local_bld_info) (Dependency (_PackageName "fltkhs") anyVersion)+ keepBuilding = (buildHook simpleUserHooks) pkg_descr local_bld_info user_hooks bld_flags+ in+ case fltkhsDependency of+ [] -> keepBuilding+ (_,[]):_ -> keepBuilding+ (_, (packageInfo:_)):_ ->+ mapM_ (updateEnv "LIBRARY_PATH") (libraryDirs packageInfo) >>+ keepBuilding++updateEnv :: String -> String -> IO ()+updateEnv env value = do+ old <- tryIOError (getEnv env)+ setEnv env ((either (const value)+ (\old' -> value +++ (case buildOS of+ Windows -> ";"+ _ -> ":") +++ old'+ )+ old))
+ examples/Example1.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE OverloadedStrings+ , BangPatterns+ , MultiWayIf+ , LambdaCase+ , TemplateHaskell+#-}+module Main where+++import Control.Monad ( void )++import qualified Graphics.UI.FLTK.LowLevel.FL as FL+import Graphics.UI.FLTK.LowLevel.Fl_Types+import Graphics.UI.FLTK.LowLevel.FLTKHS as FL++import Control.Lens++import Graphics.Rendering.Chart.Easy as Ch+import Graphics.Rendering.Chart.Backend.FLTKHS+++signal :: [Double] -> [(Double,Double)]+signal xs = [ (x,(sin (x*3.14159/45) + 1) / 2 * sin (x*3.14159/5)) | x <- xs ]++setLinesBlue :: PlotLines a b -> PlotLines a b+setLinesBlue = plot_lines_style . line_color .~ opaque blue++chart = toRenderable layout+ where+ am :: Double -> Double+ am x = (sin (x*3.14159/45) + 1) / 2 * (sin (x*3.14159/5))++ sinusoid1 = plot_lines_values .~ [[ (x,(am x)) | x <- [0,(0.5)..400]]]+ $ plot_lines_style . line_color .~ opaque blue+ $ plot_lines_title .~ "am"+ $ def++ sinusoid2 = plot_points_style .~ filledCircles 2 (opaque red)+ $ plot_points_values .~ [ (x,(am x)) | x <- [0,7..400]]+ $ plot_points_title .~ "am points"+ $ def++ layout = layout_title .~ "Amplitude Modulation"+ $ layout_plots .~ [toPlot sinusoid1,+ toPlot sinusoid2]+ $ def++++drawChart :: Ref Widget -> IO ()+drawChart widget = do+ rectangle' <- getRectangle widget+ withFlClip rectangle' $+ -- Draw either with this:+ -- void $ renderToWidget widget chart++ -- Or with the API from Graphics.Rendering.Chart.Easy:+ renderToWidgetEC widget $ do+ layout_title .= "Amplitude Modulation"+ setColors [opaque blue, opaque red]+ plot (line "am" [signal [0,(0.5)..400]])+ plot (points "am points" (signal [0,7..400]))+++main :: IO ()+main = do+ let width = 800+ height = 600++ window' <- doubleWindowNew (Size (Width width) (Height height))+ Nothing+ Nothing+ begin window'+ widget' <- widgetCustom+ (FL.Rectangle (Position (X 0) (Y 0)) (Size (Width width) (Height height)))+ Nothing+ drawChart+ defaultCustomWidgetFuncs+ end window'+ showWidget window'+ void FL.run+
+ examples/Example11.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE OverloadedStrings+ , BangPatterns+ , MultiWayIf+ , LambdaCase+ , TemplateHaskell+#-}+module Main where+++import Control.Monad ( void )++import qualified Graphics.UI.FLTK.LowLevel.FL as FL+import Graphics.UI.FLTK.LowLevel.Fl_Types+import Graphics.UI.FLTK.LowLevel.FLTKHS as FL+import Graphics.UI.FLTK.LowLevel.Fl_Enumerations++import Control.Lens++import Graphics.Rendering.Chart.Easy as Ch+import Graphics.Rendering.Chart.Backend.FLTKHS+++titles = ["Cash","Equity"]++values :: [ (String,[Double]) ]+values =+ [ ("Jun", [20,45])+ , ("Jul", [45,30])+ , ("Aug", [30,20])+ , ("Sep", [10,40])+ , ("Oct", [20,50])+ ]+++chart borders = toRenderable layout+ where+ layout =+ layout_title .~ "Sample Bars" ++ btitle+ $ layout_title_style . font_size .~ 10+ $ layout_x_axis . laxis_generate .~ autoIndexAxis alabels+ $ layout_y_axis . laxis_override .~ axisGridHide+ $ layout_left_axis_visibility . axis_show_ticks .~ False+ $ layout_plots .~ [ plotBars bars2 ]+ $ def :: Layout PlotIndex Double++ bars2 = plot_bars_titles .~ ["Cash","Equity"]+ $ plot_bars_values .~ addIndexes [[20,45],[45,30],[30,20],[70,25]]+ $ plot_bars_style .~ BarsClustered+ $ plot_bars_spacing .~ BarsFixGap 30 5+ $ plot_bars_item_styles .~ map mkstyle (cycle defaultColorSeq)+ $ def++ alabels = [ "Jun", "Jul", "Aug", "Sep", "Oct" ]++ btitle = if borders then "" else " (no borders)"+ bstyle = if borders then Just (solidLine 1.0 $ opaque black) else Nothing+ mkstyle c = (solidFillStyle c, bstyle)++++drawChart :: Ref Widget -> IO ()+drawChart widget = do+ rectangle' <- getRectangle widget+ withFlClip rectangle' $+ renderToWidgetEC widget $ do+ layout_title .= "Sample Bars"+ layout_title_style . font_size .= 10+ layout_x_axis . laxis_generate .= autoIndexAxis (map fst values)+ plot $ fmap plotBars $ bars titles (addIndexes (map snd values))++++main :: IO ()+main = do+ let width = 800+ height = 600++ window' <- doubleWindowNew (Size (Width width) (Height height))+ Nothing+ Nothing+ begin window'+ widget' <- widgetCustom+ (FL.Rectangle (Position (X 0) (Y 0)) (Size (Width width) (Height height)))+ Nothing+ drawChart+ defaultCustomWidgetFuncs+ end window'+ showWidget window'+ void FL.run+
+ examples/Example12.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE OverloadedStrings+ , BangPatterns+ , MultiWayIf+ , LambdaCase+ , TemplateHaskell+#-}+module Main where+++import Control.Monad ( void )++import qualified Graphics.UI.FLTK.LowLevel.FL as FL+import Graphics.UI.FLTK.LowLevel.Fl_Types+import Graphics.UI.FLTK.LowLevel.FLTKHS as FL+import Graphics.UI.FLTK.LowLevel.Fl_Enumerations++import Control.Lens++import Graphics.Rendering.Chart.Easy as Ch+import Graphics.Rendering.Chart.Backend.FLTKHS+++r' x y z = sqrt $ x^2 + y^2 + z^2+efield sign x y = ( sign*x/r,sign*y/r) where r = r' x y 10+bfield sign x y = (-sign*y/r^2,sign*x/r^2) where r = r' x y 10+square a s = [(x,y) | x <- range, y <- range] where range = [-a,-a+s..a] :: [Double]+add (x1,y1) (x2,y2) = (x1+x2,y1+y2)++ef (x,y) = efield 1 (x-20) y `Main.add` efield (-1) (x+20) y+bf (x,y) = bfield 1 (x-20) y `Main.add` bfield (-1) (x+20) y+grid = square 30 3++vectorField title f grid = fmap plotVectorField $ liftEC $ do+ c <- takeColor+ plot_vectors_mapf .= f+ plot_vectors_grid .= grid+ plot_vectors_style . vector_line_style . line_color .= c+ plot_vectors_style . vector_head_style . point_color .= c+ plot_vectors_title .= title++++drawChart :: Ref Widget -> IO ()+drawChart widget = do+ rectangle' <- getRectangle widget+ withFlClip rectangle' $+ renderToWidgetEC widget $ do+ setColors [opaque black, opaque blue]++ layout_title .= "Positive and Negative Charges"+ plot $ vectorField "Electric Field" ef grid+ plot $ vectorField "B-field" bf grid+++++main :: IO ()+main = do+ let width = 800+ height = 600++ window' <- doubleWindowNew (Size (Width width) (Height height))+ Nothing+ Nothing+ begin window'+ widget' <- widgetCustom+ (FL.Rectangle (Position (X 0) (Y 0)) (Size (Width width) (Height height)))+ Nothing+ drawChart+ defaultCustomWidgetFuncs+ end window'+ showWidget window'+ void FL.run+
+ examples/Example13.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE OverloadedStrings+ , BangPatterns+ , MultiWayIf+ , LambdaCase+ , TemplateHaskell+#-}+module Main where+++import Control.Monad ( void )++import qualified Graphics.UI.FLTK.LowLevel.FL as FL+import Graphics.UI.FLTK.LowLevel.Fl_Types+import Graphics.UI.FLTK.LowLevel.FLTKHS+ as FL+import Graphics.UI.FLTK.LowLevel.Fl_Enumerations++import Control.Lens++import Graphics.Rendering.Chart+import Graphics.Rendering.Chart.Grid+import Graphics.Rendering.Chart.Easy as Ch+import Graphics.Rendering.Chart.Backend.FLTKHS+++-- haskell black scholes (see http://www.espenhaug.com/black_scholes.html)++blackScholesCall :: Double -> Double -> Double -> Double -> Double -> Double+blackScholesCall s x t r v = s * normcdf d1 - x * exp (-r * t) * normcdf d2+ where+ d1 = (log (s / x) + (r + v * v / 2) * t) / (v * sqrt t)+ d2 = d1 - v * sqrt t++normcdf :: Double -> Double+normcdf x | x < 0 = 1 - w+ | otherwise = w+ where+ w =+ 1.0+ - 1.0+ / sqrt (2.0 * pi)+ * exp (-l * l / 2.0)+ * ( a1+ * k+ + a2+ * (k ** 2)+ + a3+ * (k ** 3)+ + a4+ * (k ** 4)+ + a5+ * (k ** 5)+ )+ k = 1.0 / (1.0 + 0.2316419 * l)+ l = abs x+ a1 = 0.31938153+ a2 = -0.356563782+ a3 = 1.781477937+ a4 = -1.821255978+ a5 = 1.330274429+++-- Construct a single chart for the grid+bsChart :: Double -> Double -> Double -> Layout Double Double+bsChart t r v = execEC $ do+ layout_y_axis . laxis_generate .= scaledAxis def (-10, 80)+ plot $ line "" [[ (s, blackScholesCall s 100 0.001 r v) | s <- ss ]]+ plot $ line lbl [[ (s, blackScholesCall s 100 t r v) | s <- ss ]]+ where+ ss = [50, 51 .. 150]+ lbl = "t = " ++ show t ++ ", r = " ++ show r++-- Construct a grid of charts, with a single title accross the top+grid = title `wideAbove` aboveN+ [ besideN [ layoutToGrid (bsChart t r v) | t <- ts ] | r <- rs ]+ where+ ts = [1, 2, 5]+ rs = [0.05, 0.10, 0.20]+ v = 0.10+ title = setPickFn nullPickFn+ $ label ls HTA_Centre VTA_Centre "Black Scholes Option Values"+ ls = def { _font_size = 15, _font_weight = FontWeightBold }++++++drawChart :: Ref Widget -> IO ()+drawChart widget = do+ rectangle' <- getRectangle widget+ withFlClip rectangle' $+ void $ renderToWidget widget+ $ fillBackground def+ $ gridToRenderable+ $ grid+++main :: IO ()+main = do+ let width = 800+ height = 600++ window' <- doubleWindowNew (Size (Width width) (Height height))+ Nothing+ Nothing+ begin window'+ widget' <- widgetCustom+ (FL.Rectangle (Position (X 0) (Y 0))+ (Size (Width width) (Height height))+ )+ Nothing+ drawChart+ defaultCustomWidgetFuncs+ end window'+ showWidget window'+ void FL.run+
+ examples/Example2.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE OverloadedStrings+ , BangPatterns+ , MultiWayIf+ , LambdaCase+ , TemplateHaskell+#-}+module Main where+++import Control.Monad ( void )++import qualified Graphics.UI.FLTK.LowLevel.FL as FL+import Graphics.UI.FLTK.LowLevel.Fl_Types+import Graphics.UI.FLTK.LowLevel.FLTKHS+ as FL+import Data.Time.LocalTime++import Control.Lens++import Graphics.Rendering.Chart.Easy as Ch+import Graphics.Rendering.Chart.Backend.FLTKHS++import Prices ( prices+ , mkDate+ , filterPrices+ )++prices' :: [(LocalTime, Double, Double)]+prices' = filterPrices prices (mkDate 1 1 2005) (mkDate 31 12 2006)+++chart = toRenderable layout+ where++ price1 =+ plot_lines_style+ . line_color+ .~ opaque blue+ $ plot_lines_values+ .~ [[ (d, v) | (d, v, _) <- prices' ]]+ $ plot_lines_title+ .~ "price 1"+ $ def++ price2 =+ plot_lines_style+ . line_color+ .~ opaque green+ $ plot_lines_values+ .~ [[ (d, v) | (d, _, v) <- prices' ]]+ $ plot_lines_title+ .~ "price 2"+ $ def++ layout =+ layoutlr_title+ .~ "Price History"+ $ layoutlr_left_axis+ . laxis_override+ .~ axisGridHide+ $ layoutlr_right_axis+ . laxis_override+ .~ axisGridHide+ $ layoutlr_x_axis+ . laxis_override+ .~ axisGridHide+ $ layoutlr_plots+ .~ [Left (toPlot price1), Right (toPlot price2)]+ $ layoutlr_grid_last+ .~ False+ $ def++++drawChart :: Ref Widget -> IO ()+drawChart widget = do+ rectangle' <- getRectangle widget+ let (x', y', w', h') = fromRectangle rectangle'+ withFlClip rectangle' $+ renderToWidgetEC widget $ do+ layoutlr_title .= "Price History"+ layoutlr_left_axis . laxis_override .= axisGridHide+ layoutlr_right_axis . laxis_override .= axisGridHide+ plotLeft (line "price 1" [[ (d, v) | (d, v, _) <- prices' ]])+ plotRight (line "price 2" [[ (d, v) | (d, _, v) <- prices' ]])++++main :: IO ()+main = do+ let width = 800+ height = 600++ window' <- doubleWindowNew (Size (Width width) (Height height))+ Nothing+ Nothing+ begin window'+ widget' <- widgetCustom+ (FL.Rectangle (Position (X 0) (Y 0))+ (Size (Width width) (Height height))+ )+ Nothing+ drawChart+ defaultCustomWidgetFuncs+ end window'+ showWidget window'+ void FL.run+
+ examples/Example3.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE OverloadedStrings+ , BangPatterns+ , MultiWayIf+ , LambdaCase+ , TemplateHaskell+#-}+module Main where+++import Control.Monad ( void )++import qualified Graphics.UI.FLTK.LowLevel.FL as FL+import Graphics.UI.FLTK.LowLevel.Fl_Types+import Graphics.UI.FLTK.LowLevel.FLTKHS+ as FL+import Data.Colour+import Data.Colour.SRGB+import Data.Time.LocalTime+import Data.Time.Calendar++import Control.Lens++import Graphics.Rendering.Chart.Easy as Ch+import Graphics.Rendering.Chart.Backend.FLTKHS++import Prices ( prices1 )++fillBetween title vs = liftEC $ do+ plot_fillbetween_title .= title+ color <- takeColor+ plot_fillbetween_style .= solidFillStyle color+ plot_fillbetween_values .= vs+++green1 = opaque $ sRGB 0.5 1 0.5+blue1 = opaque $ sRGB 0.5 0.5 1++chart = toRenderable layout+ where+ price1 =+ plot_fillbetween_style+ .~ solidFillStyle green1+ $ plot_fillbetween_values+ .~ [ (d, (0, v2)) | (d, v1, v2) <- prices1 ]+ $ plot_fillbetween_title+ .~ "price 1"+ $ def++ price2 =+ plot_fillbetween_style+ .~ solidFillStyle blue1+ $ plot_fillbetween_values+ .~ [ (d, (0, v1)) | (d, v1, v2) <- prices1 ]+ $ plot_fillbetween_title+ .~ "price 2"+ $ def++ layout =+ layout_title+ .~ "Price History"+ $ layout_grid_last+ .~ True+ $ layout_plots+ .~ [toPlot price1, toPlot price2]+ $ def+++drawChart :: Ref Widget -> IO ()+drawChart widget = do+ rectangle' <- getRectangle widget+ withFlClip rectangle' $+ renderToWidgetEC widget $ do+ layout_title .= "Price History"+ plot+ (fillBetween "price 1" [ (d, (0, v2)) | (d, v1, v2) <- prices1 ]+ )+ plot+ (fillBetween "price 2" [ (d, (0, v1)) | (d, v1, v2) <- prices1 ]+ )+++main :: IO ()+main = do+ let width = 800+ height = 600++ window' <- doubleWindowNew (Size (Width width) (Height height))+ Nothing+ Nothing+ begin window'+ widget' <- widgetCustom+ (FL.Rectangle (Position (X 0) (Y 0))+ (Size (Width width) (Height height))+ )+ Nothing+ drawChart+ defaultCustomWidgetFuncs+ end window'+ showWidget window'+ void FL.run+
+ examples/Example4.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE OverloadedStrings+ , BangPatterns+ , MultiWayIf+ , LambdaCase+ , TemplateHaskell+#-}+module Main where+++import Control.Monad ( void )++import qualified Graphics.UI.FLTK.LowLevel.FL as FL+import Graphics.UI.FLTK.LowLevel.Fl_Types+import Graphics.UI.FLTK.LowLevel.FLTKHS+ as FL++import Control.Lens++import Graphics.Rendering.Chart.Easy as Ch+import Graphics.Rendering.Chart.Backend.FLTKHS++import System.Random+++trial frac = scanl (*) 1 (map f bits)+ where+ b = 0.1++ f True = (1+frac*(1+b))+ f False = (1-frac)+ bits = randoms $ mkStdGen 0++vals :: Double -> [ (Double,LogValue) ]+vals frac = [(fromIntegral x, LogValue y) | (x,y) <- filter (\(x,_)-> x `mod` (m+1)==0) $ take n $ zip [0..] (trial frac)]+ where+ n = 1001+ m = 0+++chart :: Double -> Renderable ()+chart lwidth = toRenderable (layout 1001 (trial bits) :: Layout Double LogValue)+ where+ bits = randoms $ mkStdGen 0++ layout n t = layout_title .~ "Simulation of betting on a biased coin"+ $ layout_plots .~ [+ toPlot (plot "f=0.05" s1 n 0 (t 0.05)),+ toPlot (plot "f=0.1" s2 n 0 (t 0.1))+ ]+ $ def++ plot tt s n m t = plot_lines_style .~ s+ $ plot_lines_values .~+ [[(fromIntegral x, LogValue y) | (x,y) <-+ filter (\(x,_)-> x `mod` (m+1)==0) $ take n $ zip [0..] t]]+ $ plot_lines_title .~ tt+ $ def++ b = 0.1++ trial bits frac = scanl (*) 1 (map f bits)+ where+ f True = (1+frac*(1+b))+ f False = (1-frac)++ s1 = solidLine lwidth $ opaque green+ s2 = solidLine lwidth $ opaque blue++drawChart :: Ref Widget -> IO ()+drawChart widget = do+ rectangle' <- getRectangle widget+ withFlClip rectangle' $+ renderToWidgetEC widget $ do+ layout_title .= "Simulation of betting on a biased coin"+ plot (line "f=0.05" [vals 0.05 ])+ plot (line "f=0.1" [vals 0.1])+++main :: IO ()+main = do+ let width = 800+ height = 600++ window' <- doubleWindowNew (Size (Width width) (Height height))+ Nothing+ Nothing+ begin window'+ widget' <- widgetCustom+ (FL.Rectangle (Position (X 0) (Y 0))+ (Size (Width width) (Height height))+ )+ Nothing+ drawChart+ defaultCustomWidgetFuncs+ end window'+ showWidget window'+ void FL.run+
+ examples/Example5.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE OverloadedStrings+ , BangPatterns+ , MultiWayIf+ , LambdaCase+ , TemplateHaskell+#-}+module Main where+++import Control.Monad ( void )++import qualified Graphics.UI.FLTK.LowLevel.FL as FL+import Graphics.UI.FLTK.LowLevel.Fl_Types+import Graphics.UI.FLTK.LowLevel.FLTKHS as FL++import Control.Lens++import Graphics.Rendering.Chart.Easy as Ch+import Graphics.Rendering.Chart.Backend.FLTKHS+++values :: [ (String,Double,Bool) ]+values = [ ("Mexico City",19.2,False), ("Mumbai",12.9,False), ("Sydney",4.3,False), ("London",8.3,False), ("New York",8.2,True) ]++pitem (s,v,o) = pitem_value .~ v+ $ pitem_label .~ s+ $ pitem_offset .~ (if o then 25 else 0)+ $ def++chart = toRenderable layout+ where+ values = [ ("Mexico City",19.2,e), ("Mumbai",12.9,e), ("Sydney",4.3,e), ("London",8.3,e), ("New York",8.2,e1) ]+ e = 0+ e1 = 25+ pitem (s,v,o) = pitem_value .~ v+ $ pitem_label .~ s+ $ pitem_offset .~ o+ $ def++ layout = pie_title .~ "Relative Population"+ $ pie_plot . pie_data .~ map pitem values+ $ def++++drawChart :: Ref Widget -> IO ()+drawChart widget = do+ rectangle' <- getRectangle widget+ withFlClip rectangle' $+ renderToWidgetEC widget $ do+ pie_title .= "Relative Population"+ pie_plot . pie_data .= map pitem values++++main :: IO ()+main = do+ let width = 800+ height = 600++ window' <- doubleWindowNew (Size (Width width) (Height height))+ Nothing+ Nothing+ begin window'+ widget' <- widgetCustom+ (FL.Rectangle (Position (X 0) (Y 0)) (Size (Width width) (Height height)))+ Nothing+ drawChart+ defaultCustomWidgetFuncs+ end window'+ showWidget window'+ void FL.run+
+ examples/Example7.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE OverloadedStrings+ , BangPatterns+ , MultiWayIf+ , LambdaCase+ , TemplateHaskell+#-}+module Main where+++import Control.Monad ( void )++import qualified Graphics.UI.FLTK.LowLevel.FL as FL+import Graphics.UI.FLTK.LowLevel.Fl_Types+import Graphics.UI.FLTK.LowLevel.FLTKHS+ as FL+import Control.Lens++import Graphics.Rendering.Chart.Easy as Ch+import Graphics.Rendering.Chart.Backend.FLTKHS+++circle :: [(Double,Double)]+circle = [ (r a * sin (a*dr),r a * cos (a*dr)) | a <- [0,0.5..360::Double] ]+ where+ dr = 2 * pi / 360+ r a = 0.8 * cos (a * 20 * pi /360)+++chart = toRenderable layout+ where+ circle = [ (r a * sin (a*dr),r a * cos (a*dr)) | a <- [0,0.5..360::Double] ]+ where+ dr = 2 * pi / 360+ r a = 0.8 * cos (a * 20 * pi /360)++ circleP = plot_lines_values .~ [circle]+ $ plot_lines_style .~ solidLine 1.0 (opaque blue)+ $ def++ layout = layout_title .~ "Parametric Plot"+ $ layout_plots .~ [toPlot circleP]+ $ def+++++drawChart :: Ref Widget -> IO ()+drawChart widget = do+ rectangle' <- getRectangle widget+ withFlClip rectangle' $+ renderToWidgetEC widget $ do+ layout_title .= "Parametric Plot"+ plot (line "" [circle])++++main :: IO ()+main = do+ let width = 800+ height = 600++ window' <- doubleWindowNew (Size (Width width) (Height height))+ Nothing+ Nothing+ begin window'+ widget' <- widgetCustom+ (FL.Rectangle (Position (X 0) (Y 0))+ (Size (Width width) (Height height))+ )+ Nothing+ drawChart+ defaultCustomWidgetFuncs+ end window'+ showWidget window'+ void FL.run+
+ examples/Example8.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE OverloadedStrings+ , BangPatterns+ , MultiWayIf+ , LambdaCase+ , TemplateHaskell+#-}+module Main where+++import Control.Monad ( void )++import qualified Graphics.UI.FLTK.LowLevel.FL as FL+import Graphics.UI.FLTK.LowLevel.Fl_Types+import Graphics.UI.FLTK.LowLevel.FLTKHS+ as FL+import Graphics.UI.FLTK.LowLevel.Fl_Enumerations++import Data.Time.LocalTime+import Data.Time.Calendar++import Control.Lens++import Graphics.Rendering.Chart.Layout+import Graphics.Rendering.Chart+import Graphics.Rendering.Chart.Easy as Ch+import Graphics.Rendering.Chart.Backend.FLTKHS++import Prices ( prices1 )+import System.Random++++values :: [(LocalTime, Double, Int, Int)]+values = [ (d, v, z, t) | ((d, v, _), z, t) <- zip3 prices1 zs ts ]+ where+ zs = randoms $ mkStdGen 0+ ts = randomRs (-2, 27) $ mkStdGen 1++++++drawChart :: Ref Widget -> IO ()+drawChart widget = do+ rectangle' <- getRectangle widget+ let coords@(x', y', w', h') = fromRectangle rectangle'+ withFlClip rectangle' $ do+ renderToWidgetEC widget $ do+ layout_title .= "Price History"+ layout_background .= solidFillStyle (opaque white)+ layout_foreground .= (opaque black)+ layout_left_axis_visibility . axis_show_ticks .= False++ plot (line "price 1" [[ (d, v) | (d, v, _) <- prices1 ]])++ plot $ liftEC $ do+ area_spots_4d_title .= "random value"+ area_spots_4d_max_radius .= 20+ area_spots_4d_values .= values+++main :: IO ()+main = do+ let width = 800+ height = 600++ window' <- doubleWindowNew (Size (Width width) (Height height))+ Nothing+ Nothing+ begin window'+ widget' <- widgetCustom+ (FL.Rectangle (Position (X 0) (Y 0))+ (Size (Width width) (Height height))+ )+ Nothing+ drawChart+ defaultCustomWidgetFuncs+ end window'+ showWidget window'+ void FL.run+
+ examples/Prices.hs view
@@ -0,0 +1,396 @@+module Prices where++import Data.Time.Calendar+import Data.Time.LocalTime++rawPrices :: [(Int, Int, Integer, Double, Double)]+rawPrices = [+ (03,05,2005, 16.18, 42.02),+ (04,05,2005, 16.25, 42.31),+ (05,05,2005, 16.50, 42.95),+ (06,05,2005, 16.52, 43.50),+ (09,05,2005, 16.84, 44.91),+ (10,05,2005, 16.70, 44.55),+ (11,05,2005, 16.43, 43.63),+ (12,05,2005, 16.29, 43.18),+ (13,05,2005, 15.95, 42.40),+ (16,05,2005, 15.55, 41.65),+ (17,05,2005, 15.71, 42.17),+ (18,05,2005, 15.93, 42.37),+ (19,05,2005, 16.20, 42.85),+ (20,05,2005, 15.88, 42.30),+ (23,05,2005, 15.92, 42.53),+ (24,05,2005, 16.25, 42.81),+ (25,05,2005, 16.20, 42.67),+ (26,05,2005, 16.05, 42.35),+ (27,05,2005, 16.45, 43.12),+ (30,05,2005, 16.85, 43.24),+ (31,05,2005, 16.68, 42.57),+ (01,06,2005, 16.85, 43.22),+ (02,06,2005, 17.17, 43.85),+ (03,06,2005, 17.42, 44.15),+ (06,06,2005, 17.50, 44.07),+ (07,06,2005, 17.37, 43.76),+ (08,06,2005, 17.15, 43.21),+ (09,06,2005, 17.12, 43.42),+ (10,06,2005, 17.15, 43.27),+ (14,06,2005, 17.34, 43.30),+ (15,06,2005, 17.46, 43.90),+ (16,06,2005, 17.71, 44.43),+ (17,06,2005, 18.25, 45.45),+ (20,06,2005, 18.23, 45.16),+ (21,06,2005, 18.26, 45.54),+ (22,06,2005, 18.11, 45.06),+ (23,06,2005, 17.79, 44.65),+ (24,06,2005, 17.76, 44.43),+ (27,06,2005, 17.63, 44.22),+ (28,06,2005, 18.08, 44.94),+ (29,06,2005, 18.13, 44.80),+ (30,06,2005, 18.15, 44.82),+ (01,07,2005, 18.09, 45.12),+ (04,07,2005, 18.20, 45.20),+ (05,07,2005, 18.45, 45.85),+ (06,07,2005, 18.40, 45.91),+ (07,07,2005, 18.60, 46.35),+ (08,07,2005, 18.38, 45.76),+ (11,07,2005, 18.80, 46.41),+ (12,07,2005, 18.60, 45.86),+ (13,07,2005, 18.73, 46.00),+ (14,07,2005, 18.70, 46.44),+ (15,07,2005, 18.67, 46.25),+ (18,07,2005, 18.54, 45.77),+ (19,07,2005, 18.20, 45.21),+ (20,07,2005, 18.65, 46.13),+ (21,07,2005, 19.00, 46.87),+ (22,07,2005, 19.09, 47.32),+ (25,07,2005, 19.22, 47.36),+ (26,07,2005, 19.19, 47.66),+ (27,07,2005, 19.17, 47.64),+ (28,07,2005, 19.15, 47.98),+ (29,07,2005, 19.36, 49.12),+ (01,08,2005, 19.40, 49.30),+ (02,08,2005, 19.30, 49.17),+ (03,08,2005, 19.52, 49.91),+ (04,08,2005, 19.80, 50.60),+ (05,08,2005, 19.60, 50.40),+ (08,08,2005, 19.92, 50.94),+ (09,08,2005, 20.34, 52.09),+ (10,08,2005, 20.45, 51.42),+ (11,08,2005, 20.74, 52.30),+ (12,08,2005, 21.05, 53.01),+ (15,08,2005, 21.16, 53.02),+ (16,08,2005, 20.90, 52.74),+ (17,08,2005, 20.55, 51.93),+ (18,08,2005, 20.28, 51.42),+ (19,08,2005, 20.68, 52.20),+ (22,08,2005, 21.22, 53.10),+ (23,08,2005, 21.07, 53.01),+ (24,08,2005, 20.56, 52.72),+ (25,08,2005, 19.90, 50.45),+ (26,08,2005, 20.60, 51.42),+ (29,08,2005, 20.03, 50.10),+ (30,08,2005, 20.47, 50.74),+ (31,08,2005, 20.46, 50.31),+ (01,09,2005, 20.93, 51.80),+ (02,09,2005, 20.83, 51.60),+ (05,09,2005, 20.46, 51.56),+ (06,09,2005, 20.25, 50.60),+ (07,09,2005, 20.55, 51.54),+ (08,09,2005, 20.03, 50.55),+ (09,09,2005, 20.19, 50.90),+ (12,09,2005, 20.20, 51.27),+ (13,09,2005, 20.47, 51.91),+ (14,09,2005, 20.59, 51.59),+ (15,09,2005, 20.70, 52.44),+ (16,09,2005, 20.99, 53.77),+ (19,09,2005, 21.39, 55.45),+ (20,09,2005, 21.53, 55.88),+ (21,09,2005, 20.89, 54.63),+ (22,09,2005, 21.41, 55.50),+ (23,09,2005, 21.30, 55.56),+ (26,09,2005, 21.86, 57.55),+ (27,09,2005, 22.01, 58.56),+ (28,09,2005, 21.81, 58.26),+ (29,09,2005, 22.48, 60.01),+ (30,09,2005, 22.25, 59.14),+ (03,10,2005, 22.30, 58.93),+ (04,10,2005, 22.20, 58.61),+ (05,10,2005, 21.45, 57.10),+ (06,10,2005, 20.76, 56.30),+ (07,10,2005, 20.47, 56.50),+ (10,10,2005, 20.72, 57.25),+ (11,10,2005, 20.33, 57.00),+ (12,10,2005, 20.83, 57.48),+ (13,10,2005, 20.47, 56.69),+ (14,10,2005, 19.98, 55.21),+ (17,10,2005, 20.05, 55.95),+ (18,10,2005, 20.75, 57.90),+ (19,10,2005, 20.05, 56.19),+ (20,10,2005, 20.01, 56.30),+ (21,10,2005, 20.03, 55.82),+ (24,10,2005, 19.77, 54.27),+ (25,10,2005, 20.09, 54.82),+ (26,10,2005, 20.42, 55.58),+ (27,10,2005, 20.49, 55.80),+ (28,10,2005, 20.10, 54.94),+ (31,10,2005, 20.75, 56.31),+ (01,11,2005, 20.89, 57.00),+ (02,11,2005, 20.70, 57.11),+ (03,11,2005, 21.28, 58.39),+ (04,11,2005, 21.35, 58.60),+ (07,11,2005, 21.09, 58.18),+ (08,11,2005, 21.35, 59.80),+ (09,11,2005, 21.03, 59.25),+ (10,11,2005, 21.11, 59.21),+ (11,11,2005, 21.12, 59.71),+ (14,11,2005, 21.60, 61.24),+ (15,11,2005, 21.53, 60.96),+ (16,11,2005, 21.42, 60.60),+ (17,11,2005, 21.40, 60.79),+ (18,11,2005, 21.85, 62.45),+ (21,11,2005, 21.71, 62.60),+ (22,11,2005, 21.67, 61.70),+ (23,11,2005, 21.55, 60.70),+ (24,11,2005, 21.86, 61.89),+ (25,11,2005, 22.02, 62.21),+ (28,11,2005, 22.22, 62.09),+ (29,11,2005, 21.83, 61.35),+ (30,11,2005, 21.87, 61.76),+ (01,12,2005, 21.50, 60.40),+ (02,12,2005, 21.95, 61.92),+ (05,12,2005, 22.03, 63.33),+ (06,12,2005, 21.83, 62.99),+ (07,12,2005, 21.85, 63.84),+ (08,12,2005, 21.56, 63.10),+ (09,12,2005, 21.80, 63.55),+ (12,12,2005, 21.92, 63.60),+ (13,12,2005, 21.65, 63.35),+ (14,12,2005, 21.72, 63.15),+ (15,12,2005, 21.69, 63.16),+ (16,12,2005, 21.60, 62.63),+ (19,12,2005, 21.87, 63.81),+ (20,12,2005, 22.10, 65.50),+ (21,12,2005, 22.50, 67.18),+ (22,12,2005, 22.49, 67.75),+ (23,12,2005, 22.58, 68.50),+ (28,12,2005, 22.59, 68.25),+ (29,12,2005, 22.93, 69.10),+ (30,12,2005, 22.75, 69.00),+ (03,01,2006, 23.18, 69.90),+ (04,01,2006, 23.85, 71.06),+ (05,01,2006, 23.60, 69.80),+ (06,01,2006, 23.35, 68.80),+ (09,01,2006, 24.06, 70.18),+ (10,01,2006, 23.85, 69.15),+ (11,01,2006, 23.88, 69.35),+ (12,01,2006, 23.80, 70.19),+ (13,01,2006, 23.73, 70.50),+ (16,01,2006, 23.74, 71.05),+ (17,01,2006, 23.96, 71.94),+ (18,01,2006, 23.73, 70.25),+ (19,01,2006, 24.45, 72.50),+ (20,01,2006, 24.66, 74.00),+ (23,01,2006, 24.47, 73.25),+ (24,01,2006, 24.84, 74.25),+ (25,01,2006, 25.08, 73.96),+ (27,01,2006, 26.05, 76.10),+ (30,01,2006, 26.58, 78.45),+ (31,01,2006, 25.80, 75.82),+ (01,02,2006, 25.99, 75.21),+ (02,02,2006, 25.50, 74.98),+ (03,02,2006, 25.53, 74.75),+ (06,02,2006, 25.85, 75.57),+ (07,02,2006, 25.70, 75.06),+ (08,02,2006, 24.37, 72.75),+ (09,02,2006, 24.68, 72.77),+ (13,02,2006, 23.88, 70.95),+ (14,02,2006, 24.16, 72.37),+ (15,02,2006, 24.35, 71.84),+ (16,02,2006, 24.29, 71.89),+ (17,02,2006, 23.88, 71.65),+ (20,02,2006, 24.54, 74.90),+ (21,02,2006, 24.98, 75.50),+ (22,02,2006, 24.90, 73.24),+ (23,02,2006, 25.28, 74.69),+ (24,02,2006, 24.55, 72.20),+ (27,02,2006, 24.66, 73.00),+ (28,02,2006, 24.25, 71.20),+ (01,03,2006, 24.03, 70.25),+ (02,03,2006, 24.45, 70.50),+ (03,03,2006, 24.34, 70.35),+ (06,03,2006, 24.51, 70.85),+ (08,03,2006, 23.60, 67.95),+ (09,03,2006, 23.70, 68.65),+ (10,03,2006, 23.37, 67.50),+ (13,03,2006, 23.93, 70.36),+ (14,03,2006, 23.64, 69.45),+ (15,03,2006, 23.90, 69.40),+ (16,03,2006, 24.46, 70.90),+ (17,03,2006, 24.70, 71.25),+ (20,03,2006, 25.24, 72.85),+ (21,03,2006, 25.32, 73.08),+ (22,03,2006, 25.18, 72.99),+ (23,03,2006, 25.57, 74.34),+ (24,03,2006, 25.92, 75.23),+ (27,03,2006, 26.78, 77.05),+ (28,03,2006, 26.85, 77.13),+ (30,03,2006, 27.60, 77.96),+ (31,03,2006, 28.00, 78.85),+ (03,01,2007, 23.18, 69.90),+ (04,01,2007, 23.85, 71.06),+ (05,01,2007, 23.60, 69.80),+ (06,01,2007, 23.35, 68.80),+ (09,01,2007, 24.06, 70.18),+ (10,01,2007, 23.85, 69.15),+ (11,01,2007, 23.88, 69.35),+ (12,01,2007, 23.80, 70.19),+ (13,01,2007, 23.73, 70.50),+ (16,01,2007, 23.74, 71.05),+ (17,01,2007, 23.96, 71.94),+ (18,01,2007, 23.73, 70.25),+ (19,01,2007, 24.45, 72.50),+ (20,01,2007, 24.66, 74.00),+ (23,01,2007, 24.47, 73.25),+ (24,01,2007, 24.84, 74.25),+ (25,01,2007, 25.08, 73.96),+ (27,01,2007, 26.05, 76.10),+ (30,01,2007, 26.58, 78.45),+ (31,01,2007, 25.80, 75.82),+ (01,02,2007, 25.99, 75.21),+ (02,02,2007, 25.50, 74.98),+ (03,02,2007, 25.53, 74.75),+ (06,02,2007, 25.85, 75.57),+ (07,02,2007, 25.70, 75.06),+ (08,02,2007, 24.37, 72.75),+ (09,02,2007, 24.68, 72.77),+ (13,02,2007, 23.88, 70.95),+ (14,02,2007, 24.16, 72.37),+ (15,02,2007, 24.35, 71.84),+ (16,02,2007, 24.29, 71.89),+ (17,02,2007, 23.88, 71.65),+ (20,02,2007, 24.54, 74.90),+ (21,02,2007, 24.98, 75.50),+ (22,02,2007, 24.90, 73.24),+ (23,02,2007, 25.28, 74.69),+ (24,02,2007, 24.55, 72.20),+ (27,02,2007, 24.66, 73.00),+ (28,02,2007, 24.25, 71.20),+ (01,03,2007, 24.03, 70.25),+ (02,03,2007, 24.45, 70.50),+ (03,03,2007, 24.34, 70.35),+ (06,03,2007, 24.51, 70.85),+ (08,03,2007, 23.60, 67.95),+ (09,03,2007, 23.70, 68.65),+ (10,03,2007, 23.37, 67.50),+ (13,03,2007, 23.93, 70.36),+ (14,03,2007, 23.64, 69.45),+ (15,03,2007, 23.90, 69.40),+ (16,03,2007, 24.46, 70.90),+ (17,03,2007, 24.70, 71.25),+ (20,03,2007, 25.24, 72.85),+ (21,03,2007, 25.32, 73.08),+ (22,03,2007, 25.18, 72.99),+ (23,03,2007, 25.57, 74.34),+ (24,03,2007, 25.92, 75.23),+ (27,03,2007, 26.78, 77.05),+ (28,03,2007, 26.85, 77.13),+ (30,03,2007, 27.60, 77.96),+ (31,03,2007, 28.00, 78.85)+ ]++rawHourly :: [(Int, Int, Integer, Rational, Double, Double)]+rawHourly = [+ (03,05,2005,00, 16.18, 42.02),+ (03,05,2005,01, 16.25, 42.31),+ (03,05,2005,02, 16.50, 42.95),+ (03,05,2005,03, 16.52, 43.50),+ (03,05,2005,04, 16.84, 44.91),+ (03,05,2005,05, 16.70, 44.55),+ (03,05,2005,06, 16.43, 43.63),+ (03,05,2005,07, 16.29, 43.18),+ (03,05,2005,08, 15.95, 42.40),+ (03,05,2005,09, 15.55, 41.65),+ (03,05,2005,10, 15.71, 42.17),+ (03,05,2005,11, 15.93, 42.37),+ (03,05,2005,12, 16.20, 42.85),+ (03,05,2005,13, 15.88, 42.30),+ (03,05,2005,14, 15.92, 42.53),+ (03,05,2005,15, 16.25, 42.81),+ (03,05,2005,16, 16.20, 42.67),+ (03,05,2005,17, 16.05, 42.35),+ (03,05,2005,18, 16.45, 43.12),+ (03,05,2005,19, 16.85, 43.24),+ (03,05,2005,20, 16.68, 42.57),+ (03,05,2005,21, 16.85, 43.22),+ (03,05,2005,22, 17.17, 43.85),+ (03,05,2005,23, 17.42, 44.15),+ (04,05,2005,00, 17.50, 44.07),+ (04,05,2005,01, 17.37, 43.76),+ (04,05,2005,02, 17.15, 43.21),+ (04,05,2005,03, 17.12, 43.42),+ (04,05,2005,04, 17.15, 43.27),+ (04,05,2005,05, 17.34, 43.30),+ (04,05,2005,06, 17.46, 43.90),+ (04,05,2005,07, 17.71, 44.43),+ (04,05,2005,08, 18.25, 45.45),+ (04,05,2005,09, 18.23, 45.16),+ (04,05,2005,10, 18.26, 45.54),+ (04,05,2005,11, 18.11, 45.06),+ (04,05,2005,12, 17.79, 44.65)+ ]++prices :: [(LocalTime,Double,Double)]+prices = [ (mkDate dd mm yyyy, p1, p2) | (dd,mm,yyyy,p1,p2) <- rawPrices ]++hourlyPrices :: [(LocalTime,Double,Double)]+hourlyPrices = [ (mkDateTime dd mm yyyy hh 00, p1, p2)+ | (dd,mm,yyyy,hh,p1,p2) <- rawHourly ]++minutePrices :: [(LocalTime,Double,Double)]+minutePrices = [ (mkDateTime dd mm yyyy 05 hh, p1, p2)+ | (dd,mm,yyyy,hh,p1,p2) <- take 24 rawHourly ]+ ++ [ (mkDateTime dd mm yyyy 05 (hh+24), p1, p2)+ | (dd,mm,yyyy,hh,p1,p2) <- take 24 rawHourly ]++secondPrices :: [(LocalTime,Double,Double)]+secondPrices = [ (mkSeconds ss, p1, p2)+ | (ss,(_,_,_,p1,p2)) <- zip [0..] rawPrices ]++filterPrices :: Ord a => [(a, b, c)] -> a -> a -> [(a, b, c)]+filterPrices prices t1 t2 = [ v | v@(d,_,_) <- prices+ , let t = d in t >= t1 && t <= t2]++prices1 = filterPrices prices (mkDate 1 1 2005) (mkDate 31 12 2005)+prices2 = filterPrices prices (mkDate 1 6 2005) (mkDate 1 9 2005)+prices3 = filterPrices prices (mkDate 1 1 2006) (mkDate 10 1 2006)+prices4 = filterPrices prices (mkDate 1 8 2005) (mkDate 31 8 2005)+prices5 = filterPrices prices (mkDate 1 6 2005) (mkDate 15 7 2005)+prices6 = filterPrices prices (mkDate 1 6 2005) (mkDate 2 7 2005)+prices7 = filterPrices prices (mkDate 20 6 2005) (mkDate 12 7 2005)+prices8 = filterPrices prices (mkDate 6 6 2005) (mkDate 9 6 2005)+prices9 = filterPrices prices (mkDate 6 6 2005) (mkDate 8 6 2005)+prices10 = hourlyPrices+prices10a = take 31 hourlyPrices+prices10b = take 15 hourlyPrices+prices11 = filterPrices hourlyPrices (mkDateTime 3 5 2005 02 30)+ (mkDateTime 4 5 2005 02 30)+prices12 = filterPrices hourlyPrices (mkDateTime 3 5 2005 02 30)+ (mkDateTime 3 5 2005 06 30)+prices13 = minutePrices+prices13a = take 24 minutePrices+prices13b = take 16 minutePrices+prices14 = secondPrices+prices14a = take 90 secondPrices+prices14b = take 35 secondPrices+prices14c = take 30 secondPrices+prices14d = take 7 secondPrices++mkDate dd mm yyyy =+ LocalTime (fromGregorian (fromIntegral yyyy) mm dd) midnight+mkDateTime dd mm yyyy hh nn =+ LocalTime (fromGregorian (fromIntegral yyyy) mm dd)+ (dayFractionToTimeOfDay ((hh*60+nn)/1440))++mkSeconds ss = LocalTime (fromGregorian (fromIntegral 2009) 11 23)+ (dayFractionToTimeOfDay (((14*60+32)*60+ss)/(1440*60)))+
+ src/Graphics/Rendering/Chart/Backend/FLTKHS.hs view
@@ -0,0 +1,464 @@+{-|+Module : Graphics.Rendering.Chart.Backend.FLTKHS+Description : Provides a backend for the Chart library using a FLTKHS widget for rendering+Copyright : (c) Michael Oswald, 2019+License : BSD-3+Maintainer : michael.oswald@onikudaki.net+Stability : experimental+Portability : POSIX++To render a Chart to a widget, it is best to create a custom widget and override it's draw method.++An example:++@+widget' <- widgetCustom+ (FL.Rectangle (Position (X 0) (Y 0)) (Size (Width width) (Height height)))+ Nothing+ drawChart+ defaultCustomWidgetFuncs+@++Here, 'drawChart' is the provided draw method for the widget. A possible implementation+could be this:++@+-- The char itself, to be used here with "Graphics.Rendering.Chart.Easy"+signal :: [Double] -> [(Double,Double)]+signal xs = [ (x,(sin (x*3.14159/45) + 1) / 2 * sin (x*3.14159/5)) | x <- xs ]++-- the overloaded drawing function+drawChart :: Ref Widget -> IO ()+drawChart widget = do+ -- determine a clipping area for the whole widget first+ rectangle' <- getRectangle widget++ -- with this clipping area, we draw the graph. This graph is taken from Example 1 <https://github.com/timbod7/haskell-chart/wiki/example-1>+ -- from the Chart library+ withFlClip rectangle' $+ renderToWidgetEC widget $ do+ layout_title .= "Amplitude Modulation"+ setColors [opaque blue, opaque red]+ plot (line "am" [signal [0,(0.5)..400]])+ plot (points "am points" (signal [0,7..400]))+@+++-}+{-# LANGUAGE OverloadedStrings+ , BangPatterns+ , BinaryLiterals+ , NumericUnderscores+ , FlexibleInstances+ , GADTs+ , ExistentialQuantification+#-}+module Graphics.Rendering.Chart.Backend.FLTKHS+ ( renderToWidget+ , renderToWidgetEC+ , runBackend+ , FLTKHSEnv+ , defaultEnv+ , withFlClip+ )+where++import Control.Monad.Operational+import Control.Monad ( void )+import Control.Exception ( bracket+ , bracket_+ )++import qualified Data.Text as T+import Data.Char ( chr )+import Data.Colour+import Data.Colour.SRGB+import Data.Bits+import Data.Default.Class++import Graphics.UI.FLTK.LowLevel.Fl_Types+import Graphics.UI.FLTK.LowLevel.FLTKHS+ as FL+import Graphics.UI.FLTK.LowLevel.Fl_Enumerations++import Graphics.Rendering.Chart.Backend+ as G+import Graphics.Rendering.Chart.Backend.Impl+import Graphics.Rendering.Chart.Geometry+ as G+import Graphics.Rendering.Chart.Renderable+import Graphics.Rendering.Chart.Drawing+import Graphics.Rendering.Chart.State ( EC+ , execEC+ )+++-- | The environment internally used for drawing+data FLTKHSEnv = FLTKHSEnv {+ flAlignmentFns :: AlignmentFns+ , flFontColor :: Color+ , flPathColor :: Color+ , flFillColor :: Color+ , flCurrentMatrix :: Matrix+ }++-- | Provide a default environment. The 'AlignmentFns' used should be 'bitmapAlignmentFns'+-- from the Chart library+defaultEnv :: AlignmentFns -> FLTKHSEnv+defaultEnv alignFns = FLTKHSEnv+ { flAlignmentFns = alignFns+ , flFontColor = blackColor+ , flPathColor = blackColor+ , flFillColor = whiteColor+ , flCurrentMatrix = Matrix 1.0 0.0 0.0 1.0 0.0 0.0+ }+++-- | Render a 'Renderable' to a widget. It renders to the full widget (it gets the rectangle+-- of the widgets area) and uses that as the sizes for rendering.+{-# INLINABLE renderToWidget #-}+renderToWidget :: Ref Widget -> Renderable a -> IO (PickFn a)+renderToWidget widget r = do+ rectangle' <- getRectangle widget+ let (x, y, w', h') = fromRectangle rectangle'+ cr = render r (fromIntegral w', fromIntegral h')+ runBackend (defaultEnv bitmapAlignmentFns)+ (withTranslation (Point (fromIntegral x) (fromIntegral y)) cr)+++-- | Render a Chart created with the statefull "Graphics.Rendering.Chart.Easy" API.+-- Calls 'renderToWidget' internally+{-# INLINABLE renderToWidgetEC #-}+renderToWidgetEC+ :: (Default r, ToRenderable r) => Ref Widget -> EC r () -> IO ()+renderToWidgetEC widget ec =+ void $ renderToWidget widget (toRenderable (execEC ec))++-- | Run this backends renderer+{-# INLINABLE runBackend #-}+runBackend :: FLTKHSEnv -> BackendProgram a -> IO a+runBackend env' m' = eval env' (view m')+ where+ eval :: FLTKHSEnv -> ProgramView ChartBackendInstr a -> IO a+ eval _ (Return v ) = return v+ eval env (StrokePath p :>>= f) = flStrokePath env p >>= step env f+ eval env (FillPath p :>>= f) = flFillPath env p >>= step env f+ eval env (GetTextSize s :>>= f) = flTextSize s >>= step env f+ eval env (DrawText p s :>>= f) = flDrawText env p s >>= step env f+ eval env (GetAlignments :>>= f) = step env f (flAlignmentFns env)+ eval env (WithTransform m p :>>= f) = flWithTransform env m p >>= step env f+ eval env (WithFontStyle font p :>>= f) =+ flWithFontStyle env font p >>= step env f+ eval env (WithFillStyle fs p :>>= f) =+ flWithFillStyle env fs p >>= step env f+ eval env (WithLineStyle ls p :>>= f) =+ flWithLineStyle env ls p >>= step env f+ eval env (WithClipRegion r p :>>= f) =+ flWithClipRegion env r p >>= step env f++ step :: FLTKHSEnv -> (v -> BackendProgram a) -> v -> IO a+ step env f v = runBackend env (f v)++++{-# INLINABLE withColor #-}+withColor :: IO a -> IO a+withColor action = bracket flcColor flcSetColor (const action)++++{-# INLINABLE isClosed #-}+isClosed :: Path -> Bool+isClosed G.Close = True+isClosed End = False+isClosed (MoveTo _ p ) = isClosed p+isClosed (LineTo _ p ) = isClosed p+isClosed (Arc _ _ _ _ p) = isClosed p+isClosed (ArcNeg _ _ _ _ p) = isClosed p+++{-# INLINABLE radToDegree #-}+radToDegree :: Double -> Double+radToDegree !theta = theta * 180 / pi++{-# INLINABLE pointToPrecisePosition #-}+pointToPrecisePosition :: Point -> PrecisePosition+pointToPrecisePosition p =+ PrecisePosition (PreciseX (p_x p)) (PreciseY (p_y p))++{-# INLINABLE pointToPosition #-}+pointToPosition :: Point -> Position+pointToPosition p = Position (X x) (Y y)+ where+ x = Prelude.round (p_x p)+ y = Prelude.round (p_y p)+++-- instance Show Path where+-- show (MoveTo p path) = "MoveTo " <> show p <> " " <> show path+-- show (LineTo p path) = "LineTo " <> show p <> " " <> show path+-- show (Arc p rad a1 a2 path) = "Arc " <> show p <> " " <> show rad <> " " <> show a1 <> " " <> show a2 <> " " <> show path+-- show (ArcNeg p rad a1 a2 path) = "ArcNeg " <> show p <> " " <> show rad <> " " <> show a1 <> " " <> show a2 <> " " <> show path+-- show End = "End"+-- show G.Close = "Close"+++{-# INLINABLE checkDouble #-}+checkDouble :: Double -> Double+checkDouble d = if isNaN d then 0 else d+++flStrokePath :: FLTKHSEnv -> Path -> IO ()+flStrokePath env p' = withColor $ do+ flcSetColor (flPathColor env)+ let closed = isClosed p'+ if closed then flcBeginLoop else flcBeginLine+ go p' closed+ where+ go (MoveTo p path) closed = do+ if closed+ then do+ flcEndLoop+ flcBeginLoop+ else do+ flcEndLine+ flcBeginLine+ flcVertex (PrecisePosition (PreciseX (p_x p)) (PreciseY (p_y p)))+ go path closed+ go (LineTo p path) closed = do+ flcVertex (PrecisePosition (PreciseX (p_x p)) (PreciseY (p_y p)))+ go path closed+ go (Arc p r a1 a2 path) closed = do+ flcArcByRadius pt (checkDouble r) a1t a2t+ go path closed+ where+ pt = pointToPrecisePosition p+ !a1t = PreciseAngle (360 - radToDegree a1)+ !a2t = PreciseAngle (360 - radToDegree a2)+ go (ArcNeg p r a1 a2 path) closed = do+ flcArcByRadius pt (checkDouble r) a1t a2t+ go path closed+ where+ pt = pointToPrecisePosition p+ !a1t = PreciseAngle (radToDegree a1)+ !a2t = PreciseAngle (radToDegree a2)+ go End closed = if closed then flcEndLoop else flcEndLine+ go G.Close closed = if closed then flcEndLoop else flcEndLine++++flFillPath :: FLTKHSEnv -> Path -> IO ()+flFillPath env p' = withColor $ do+ flcSetColor (flFillColor env)+ flcBeginComplexPolygon+ go p'+ where+ go (MoveTo p path) = do+ flcGap+ flcVertex (PrecisePosition (PreciseX (p_x p)) (PreciseY (p_y p)))+ go path+ go (LineTo p path) = do+ flcVertex (PrecisePosition (PreciseX (p_x p)) (PreciseY (p_y p)))+ go path+ go (Arc p r a1 a2 path) = do+ flcArcByRadius pt (checkDouble r) a1t a2t+ go path+ where+ pt = pointToPrecisePosition p+ !a1t = PreciseAngle (360 - radToDegree a1)+ !a2t = PreciseAngle (360 - radToDegree a2)+ go (ArcNeg p r a1 a2 path) = do+ flcArcByRadius pt (checkDouble r) a1t a2t+ go path+ where+ pt = pointToPrecisePosition p+ !a1t = PreciseAngle (radToDegree a1)+ !a2t = PreciseAngle (radToDegree a2)+ go End = flcEndComplexPolygon+ go G.Close = flcEndComplexPolygon+++flTextSize :: String -> IO TextSize+flTextSize text = do+ FL.Rectangle (Position _ _) (Size (Width w) (Height h)) <- flcTextExtents+ (T.pack text)+ descent <- flcDescent+ let res = TextSize { textSizeWidth = fromIntegral w+ , textSizeHeight = fromIntegral h+ , textSizeDescent = fromIntegral descent+ , textSizeAscent = fromIntegral (h - descent)+ , textSizeYBearing = 0+ }+ pure res++{-# INLINABLE apply #-}+apply :: Matrix -> Point -> Point+apply (Matrix a1 a2 b1 b2 c1 c2) (Point x y) =+ let new_x = a1 * x + b1 * y + c1+ new_y = a2 * x + b2 * y + c2+ in Point new_x new_y+++{-# INLINABLE flDrawText #-}+flDrawText :: FLTKHSEnv -> Point -> String -> IO ()+flDrawText env p text = withColor $ do+ flcSetColor (flFontColor env)+ flcDraw (T.pack text) (pointToPosition (apply (flCurrentMatrix env) p))+++++withSavedLineStyle :: IO a -> IO a+withSavedLineStyle action = bracket flcColor reset (const action)+ where+ reset col = do+ flcLineStyle (LineDrawStyle Nothing Nothing Nothing) Nothing Nothing+ flcSetColor col+++{-# INLINABLE clampI #-}+clampI :: Int -> Int+clampI x | x < 0 = 0+ | x > 255 = 255+ | otherwise = x++flWithLineStyle :: FLTKHSEnv -> G.LineStyle -> BackendProgram a -> IO a+flWithLineStyle env ls p = withSavedLineStyle $ do+ let width = Prelude.round (_line_width ls)+ capStyle = convCapStyle (_line_cap ls)+ joinStyle = convJoinStyle (_line_join ls)+ style = LineDrawStyle Nothing (Just capStyle) (Just joinStyle)++ dashes = T.pack . map conv $ _line_dashes ls++ conv :: Double -> Char+ conv = chr . clampI . Prelude.round++ col = convColor (_line_color ls)++ flcLineStyle style (Just (Width width)) (Just dashes)+ runBackend env { flPathColor = col } p++flWithFillStyle :: FLTKHSEnv -> FillStyle -> BackendProgram a -> IO a+flWithFillStyle env fs =+ runBackend env { flFillColor = convColor (_fill_color fs) }++-- | Performs a drawing action in a widget within a defined clipping rectangle. This+-- is a convenience function, as FLTKHS is quite statefull and a 'flcPushClip' must+-- be closed by a 'flcPopClip'. So this function exactly provides this, while+-- executing the given drawing action in between push and pop+{-# INLINABLE withFlClip #-}+withFlClip :: FL.Rectangle -> IO a -> IO a+withFlClip rect = bracket_ (flcPushClip rect) flcPopClip++{-# INLINABLE flWithClipRegion #-}+flWithClipRegion :: FLTKHSEnv -> Rect -> BackendProgram a -> IO a+flWithClipRegion env (Rect p1@(Point _ _) p2@(Point _ _)) p = do+ let mat = flCurrentMatrix env+ Point x1 y1 = apply mat p1+ Point x2 y2 = apply mat p2++ !rect = FL.Rectangle+ (Position (X (Prelude.round minx)) (Y (Prelude.round miny)))+ (Size (Width (Prelude.round w)) (Height (Prelude.round h)))+ !minx = min x1 x2+ !miny = min y1 y2+ !maxx = max x1 x2+ !maxy = max y1 y2+ !w = maxx - minx+ !h = maxy - miny+ withFlClip rect (runBackend env p)+++{-# INLINABLE withMatrix #-}+withMatrix :: IO a -> IO a+withMatrix = bracket_ flcPushMatrix flcPopMatrix+++flWithTransform :: FLTKHSEnv -> Matrix -> BackendProgram a -> IO a+flWithTransform env mat@(Matrix xx' yx' xy' yy' x0' y0') p = withMatrix $ do+ flcMultMatrix xx' yx' xy' yy' (ByXY (ByX x0') (ByY y0'))+ runBackend env { flCurrentMatrix = flCurrentMatrix env * mat } p+++{-# INLINABLE withFlFont #-}+withFlFont :: IO a -> IO a+withFlFont action = bracket acquire release (const action)+ where+ acquire = (,) <$> flcFont <*> flcSize+ release (font, size) = flcSetFont font size++++{-# INLINABLE flWithFontStyle #-}+flWithFontStyle :: FLTKHSEnv -> FontStyle -> BackendProgram a -> IO a+flWithFontStyle env font p = withFlFont $ do+ let fontSize = FontSize (Prelude.round (_font_size font))+ flfont = selectFont font+ flcSetFont flfont fontSize+ runBackend env { flFontColor = convColor (_font_color font) } p+++{-# INLINABLE selectFont #-}+selectFont :: FontStyle -> Font+selectFont fs = case (_font_name fs, _font_slant fs, _font_weight fs) of+ ("serif" , FontSlantNormal , FontWeightNormal) -> times+ ("serif" , FontSlantNormal , FontWeightBold ) -> timesBold+ ("serif" , FontSlantItalic , FontWeightNormal) -> timesItalic+ ("serif" , FontSlantOblique, FontWeightNormal) -> timesItalic+ ("serif" , FontSlantItalic , FontWeightBold ) -> timesBoldItalic+ ("serif" , FontSlantOblique, FontWeightBold ) -> timesBoldItalic++ ("sans-serif", FontSlantNormal , FontWeightNormal) -> helvetica+ ("sans-serif", FontSlantNormal , FontWeightBold ) -> helveticaBold+ ("sans-serif", FontSlantItalic , FontWeightNormal) -> helveticaItalic+ ("sans-serif", FontSlantOblique, FontWeightNormal) -> helveticaItalic+ ("sans-serif", FontSlantItalic , FontWeightBold ) -> helveticaBoldItalic+ ("sans-serif", FontSlantOblique, FontWeightBold ) -> helveticaBoldItalic++ ("monospace" , FontSlantNormal , FontWeightNormal) -> courier+ ("monospace" , FontSlantNormal , FontWeightBold ) -> courierBold+ ("monospace" , FontSlantItalic , FontWeightNormal) -> courierItalic+ ("monospace" , FontSlantOblique, FontWeightNormal) -> courierItalic+ ("monospace" , FontSlantItalic , FontWeightBold ) -> courierBoldItalic+ ("monospace" , FontSlantOblique, FontWeightBold ) -> courierBoldItalic++ (_ , FontSlantNormal , FontWeightNormal) -> helvetica+ (_ , FontSlantNormal , FontWeightBold ) -> helveticaBold+ (_ , FontSlantItalic , FontWeightNormal) -> helveticaItalic+ (_ , FontSlantOblique, FontWeightNormal) -> helveticaItalic+ (_ , FontSlantItalic , FontWeightBold ) -> helveticaBoldItalic+ (_ , FontSlantOblique, FontWeightBold ) -> helveticaBoldItalic+++++{-# INLINABLE convCapStyle #-}+convCapStyle :: LineCap -> CapStyle+convCapStyle LineCapButt = CapStyleFlat+convCapStyle LineCapRound = CapStyleRound+convCapStyle LineCapSquare = CapStyleSquare++{-# INLINABLE convJoinStyle #-}+convJoinStyle :: LineJoin -> JoinStyle+convJoinStyle LineJoinMiter = JoinStyleMiter+convJoinStyle LineJoinRound = JoinStyleRound+convJoinStyle LineJoinBevel = JoinStyleBevel++{-# INLINABLE pureColour #-}+pureColour :: AlphaColour Double -> Colour Double+pureColour ac = darken (recip a) (ac `over` black) where a = alphaChannel ac++{-# INLINABLE convColor #-}+convColor :: AlphaColour Double -> Color+convColor color =+ let (RGB r g b) = toSRGB24 (pureColour color)+ !col = Color+ ( fromIntegral r+ `shiftL` 24+ .|. fromIntegral g+ `shiftL` 16+ .|. fromIntegral b+ `shiftL` 8+ )+ in col