diff --git a/Chart-fltkhs.cabal b/Chart-fltkhs.cabal new file mode 100644 --- /dev/null +++ b/Chart-fltkhs.cabal @@ -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" diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -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)) diff --git a/examples/Example1.hs b/examples/Example1.hs new file mode 100644 --- /dev/null +++ b/examples/Example1.hs @@ -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 + diff --git a/examples/Example11.hs b/examples/Example11.hs new file mode 100644 --- /dev/null +++ b/examples/Example11.hs @@ -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 + diff --git a/examples/Example12.hs b/examples/Example12.hs new file mode 100644 --- /dev/null +++ b/examples/Example12.hs @@ -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 + diff --git a/examples/Example13.hs b/examples/Example13.hs new file mode 100644 --- /dev/null +++ b/examples/Example13.hs @@ -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 + diff --git a/examples/Example2.hs b/examples/Example2.hs new file mode 100644 --- /dev/null +++ b/examples/Example2.hs @@ -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 + diff --git a/examples/Example3.hs b/examples/Example3.hs new file mode 100644 --- /dev/null +++ b/examples/Example3.hs @@ -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 + diff --git a/examples/Example4.hs b/examples/Example4.hs new file mode 100644 --- /dev/null +++ b/examples/Example4.hs @@ -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 + diff --git a/examples/Example5.hs b/examples/Example5.hs new file mode 100644 --- /dev/null +++ b/examples/Example5.hs @@ -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 + diff --git a/examples/Example7.hs b/examples/Example7.hs new file mode 100644 --- /dev/null +++ b/examples/Example7.hs @@ -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 + diff --git a/examples/Example8.hs b/examples/Example8.hs new file mode 100644 --- /dev/null +++ b/examples/Example8.hs @@ -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 + diff --git a/examples/Prices.hs b/examples/Prices.hs new file mode 100644 --- /dev/null +++ b/examples/Prices.hs @@ -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))) + diff --git a/src/Graphics/Rendering/Chart/Backend/FLTKHS.hs b/src/Graphics/Rendering/Chart/Backend/FLTKHS.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Rendering/Chart/Backend/FLTKHS.hs @@ -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 + -- 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