diff --git a/.gitignore b/.gitignore new file mode 100644 --- /dev/null +++ b/.gitignore @@ -0,0 +1,4 @@ +.\#* +./ +*~ +dist/* diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +The MIT License (MIT) + +Copyright (c) 2015 Aditya Siram + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,76 @@ +#Fltkhs-demos + +These are end-to-end demos of [FLTKHS] [1], a Haskell Binding to the FLTK GUI Library + + +Fltkhs-demos aims not only to show off the features of the [fltkhs] [1] but also +serve as a way of learning the API by example. For more thorough documentation +on the [fltkhs] [1] API please see the [FLTKHS module] [2] of that package. + +## Introduction + +The demos shipped with this package are listed in `fltkhs-demos.cabal` as +separate `Executable` components. Once the package is installed they are +installed to Cabal's standard /bin/ directory (usually ~/.cabal/bin on Linux). + +Note that the executables are prefixed with \"fltkhs-\". This is in order to +prevent the demo executables from stomping over applications of the same name +the user might already have installed. Typing: + +``` + > fltkhs- +``` + +at the command line should show a complete list of available demos. + +Alternatively you can do: + +``` + > ls ~/.cabal/bin/fltkhs-* +``` + +## Learning The API + +Most of the demos are exact ports of those shipped in the 'test' directory of +the distribution. It is hoped the user will study the +Haskell demo code side-by-side with the C++ demo code in order to understand the +API. The section __API Guide__ in the [FLKTHS documentation] [2] covers this in more detail. + +## Why is the demo code so un-Haskelly? +For being written in Haskell, the demo code is horrifyingly/amazingly imperative and stateful. Although it may repulse those +who used to pure Haskell idioms it is that way for a reason. + +The demo code was never meant to be idiomatic Haskell code but a way of showing as much of the API as possible. The API itself +closely resembles the underlying C++ code which is imperative and stateful. This has the advantage of making the API easier +to learn. + +For instance, assuming FLTK was installed from source compare /src/Examples/arc.hs with /test/arc.cxx in the FLTK +source directory. There is quite a bit of correspondence and it is easy to see how the Haskell API functions map to the C++ ones. + +## Fast Compilation Flag + +This package comes with a Cabal flag `fastCompile` that is enabled by default and speeds up compilation. More information on this flag is available under the __Compilation__ section of the [FLTKHS documentation] [2]. + +To disable this flag, tell Cabal to ignore it during the `configure` step: + +``` +cabal configure -f-fastCompile +``` + +# GHCi + +The recommended way to running the REPL in a `fltkhs` application is `cabal repl`. For example to run the `fltkhs-arc` example do: + +``` +cabal repl fltkhs-arc +``` + +__NOTE__: For now it only works in GHC 7.8.x. GHC 7.10.x has an unfortunate regression that crashes GHCi because it cannot find symbols in the C library that contains the C++ bindings. This has been fixed in GHC 8. More information is available in the [ticket] [4]. + + + + + [1]: http://hackage.haskell.org/package/fltkhs/ + [2]: http://hackage.haskell.org/package/fltkhs/docs/Graphics-UI-FLTK-LowLevel-FLTKHS.html + [3]: https://github.com/deech/fltkhs-fluid-hello-world + [4]: https://ghc.haskell.org/trac/ghc/ticket/10568 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main :: IO () +main = defaultMain diff --git a/fltkhs-demos.cabal b/fltkhs-demos.cabal new file mode 100644 --- /dev/null +++ b/fltkhs-demos.cabal @@ -0,0 +1,300 @@ +name: fltkhs-demos +version: 0.0.0.3 +synopsis: FLTKHS demos. Please scroll to the bottom for more information. +description: + FLTKHS demos moved to a separate package to keep the core package free of additional dependencies. +license: MIT +license-file: LICENSE +author: Aditya Siram +maintainer: aditya.siram@gmail.com +homepage: http://github.com/deech/fltkhs-demos +-- bug-reports: +-- copyright: +category: UI,Graphics +build-type: Custom +cabal-version: >=1.20 +source-repository head + type: git + location: http://github.com/deech/fltkhs-demos + +Flag FastCompile + Description: Turn off optimizations for faster compilation + Manual: True + Default: True + +Executable fltkhs-threads + Main-Is: threads.hs + Hs-Source-Dirs: src/Examples + Build-Depends: + base == 4.*, + fltkhs >= 0.4.0.0, + stm + default-language: Haskell2010 + ghc-Options: -Wall -threaded + if impl(ghc >= 7.10) && flag(FastCompile) + ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0 + if os(windows) + ghc-Options: -optl-mwindows + if !os(darwin) && !os(windows) + ghc-Options: -pgml g++ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive" + +Executable fltkhs-pack + Main-Is: pack.hs + Hs-Source-Dirs: src/Examples + Build-Depends: + base == 4.*, + directory >= 1.2.2.0, + fltkhs >= 0.4.0.0 + default-language: Haskell2010 + ghc-Options: -Wall -threaded + if impl(ghc >= 7.10) && flag(FastCompile) + ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0 + if os(windows) + ghc-Options: -optl-mwindows + if !os(darwin) && !os(windows) + ghc-Options: -pgml g++ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive" + +Executable fltkhs-tile + Main-Is: tile.hs + Hs-Source-Dirs: src/Examples + Build-Depends: + base == 4.*, + directory, + fltkhs >= 0.4.0.0 + default-language: Haskell2010 + ghc-Options: -Wall -threaded + if impl(ghc >= 7.10) && flag(FastCompile) + ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0 + if os(windows) + ghc-Options: -optl-mwindows + if !os(darwin) && !os(windows) + ghc-Options: -pgml g++ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive" + +Executable fltkhs-nativefilechooser-simple-app + Main-Is: nativefilechooser-simple-app.hs + Hs-Source-Dirs: src/Examples + Build-Depends: + base == 4.*, + directory, + fltkhs >= 0.4.0.0 + default-language: Haskell2010 + ghc-Options: -Wall -threaded + if impl(ghc >= 7.10) && flag(FastCompile) + ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0 + if os(windows) + ghc-Options: -optl-mwindows + if !os(darwin) && !os(windows) + ghc-Options: -pgml g++ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive" + +Executable fltkhs-table-as-container + Main-Is: table-as-container.hs + Hs-Source-Dirs: src/Examples + Build-Depends: + base == 4.*, + fltkhs >= 0.4.0.0 + default-language: Haskell2010 + ghc-Options: -Wall -threaded + if impl(ghc >= 7.10) && flag(FastCompile) + ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0 + if os(windows) + ghc-Options: -optl-mwindows + if !os(darwin) && !os(windows) + ghc-Options: -pgml g++ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive" + +Executable fltkhs-texteditor-simple + Main-Is: texteditor-simple.hs + Hs-Source-Dirs: src/Examples + Build-Depends: + base == 4.*, + fltkhs >= 0.4.0.0 + default-language: Haskell2010 + ghc-Options: -Wall -threaded + if impl(ghc >= 7.10) && flag(FastCompile) + ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0 + if os(windows) + ghc-Options: -optl-mwindows + if !os(darwin) && !os(windows) + ghc-Options: -pgml g++ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive" + +Executable fltkhs-textdisplay-with-colors + Main-Is: textdisplay-with-colors.hs + Hs-Source-Dirs: src/Examples + Build-Depends: + base == 4.*, + fltkhs >= 0.4.0.0 + default-language: Haskell2010 + ghc-Options: -Wall -threaded + if impl(ghc >= 7.10) && flag(FastCompile) + ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0 + if os(windows) + ghc-Options: -optl-mwindows + if !os(darwin) && !os(windows) + ghc-Options: -pgml g++ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive" + +Executable fltkhs-doublebuffer + Main-Is: doublebuffer.hs + Hs-Source-Dirs: src/Examples + Build-Depends: + base == 4.*, + fltkhs >= 0.4.0.0 + default-language: Haskell2010 + ghc-Options: -Wall -threaded + if impl(ghc >= 7.10) && flag(FastCompile) + ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0 + if os(windows) + ghc-Options: -optl-mwindows + if !os(darwin) && !os(windows) + ghc-Options: -pgml g++ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive" + +Executable fltkhs-make-tree + Main-Is: make-tree.hs + Hs-Source-Dirs: src/Examples + Build-Depends: + base == 4.*, + fltkhs >= 0.4.0.0 + default-language: Haskell2010 + ghc-Options: -Wall -threaded + if impl(ghc >= 7.10) && flag(FastCompile) + ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0 + if os(windows) + ghc-Options: -optl-mwindows + if !os(darwin) && !os(windows) + ghc-Options: -pgml g++ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive" + +Executable fltkhs-tree-simple + Main-Is: tree-simple.hs + Hs-Source-Dirs: src/Examples + Build-Depends: + base == 4.*, + fltkhs >= 0.4.0.0 + default-language: Haskell2010 + ghc-Options: -Wall -threaded + if impl(ghc >= 7.10) && flag(FastCompile) + ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0 + if os(windows) + ghc-Options: -optl-mwindows + if !os(darwin) && !os(windows) + ghc-Options: -pgml g++ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive" + +Executable fltkhs-table-spreadsheet-with-keyboard-nav + Main-Is: table-spreadsheet-with-keyboard-nav.hs + Hs-Source-Dirs: src/Examples + Build-Depends: + base == 4.*, + fltkhs >= 0.4.0.0 + default-language: Haskell2010 + ghc-Options: -Wall -threaded + if impl(ghc >= 7.10) && flag(FastCompile) + ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0 + if os(windows) + ghc-Options: -optl-mwindows + if !os(darwin) && !os(windows) + ghc-Options: -pgml g++ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive" + +Executable fltkhs-table-simple + Main-Is: table-simple.hs + Hs-Source-Dirs: src/Examples + Build-Depends: + base == 4.*, + fltkhs >= 0.4.0.0 + default-language: Haskell2010 + ghc-Options: -Wall -threaded + if impl(ghc >= 7.10) && flag(FastCompile) + ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0 + if os(windows) + ghc-Options: -optl-mwindows + if !os(darwin) && !os(windows) + ghc-Options: -pgml g++ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive" + +Executable fltkhs-table-sort + Main-Is: table-sort.hs + Hs-Source-Dirs: src/Examples + Build-Depends: + base == 4.*, + fltkhs >= 0.4.0.0, + process + default-language: Haskell2010 + ghc-Options: -Wall -threaded + if impl(ghc >= 7.10) && flag(FastCompile) + ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0 + if os(windows) + ghc-Options: -optl-mwindows + if !os(darwin) && !os(windows) + ghc-Options: -pgml g++ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive" + +Executable fltkhs-arc + Main-Is: arc.hs + Hs-Source-Dirs: src/Examples + Build-Depends: + base == 4.*, + fltkhs >= 0.4.0.0 + default-language: Haskell2010 + ghc-Options: -Wall -threaded + if impl(ghc >= 7.10) && flag(FastCompile) + ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0 + if os(windows) + ghc-Options: -optl-mwindows + if !os(darwin) && !os(windows) + ghc-Options: -pgml g++ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive" + +Executable fltkhs-bitmap + Main-Is: bitmap.hs + Hs-Source-Dirs: src/Examples + Build-Depends: + base == 4.*, + fltkhs >= 0.4.0.0,bytestring + default-language: Haskell2010 + ghc-Options: -Wall -threaded + if impl(ghc >= 7.10) && flag(FastCompile) + ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0 + if os(windows) + ghc-Options: -optl-mwindows + if !os(darwin) && !os(windows) + ghc-Options: -pgml g++ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive" + +Executable fltkhs-boxtype + Main-Is: boxtype.hs + Hs-Source-Dirs: src/Examples + Build-Depends: + base == 4.*, + fltkhs >= 0.4.0.0,bytestring + default-language: Haskell2010 + ghc-Options: -Wall -threaded + if impl(ghc >= 7.10) && flag(FastCompile) + ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0 + if os(windows) + ghc-Options: -optl-mwindows + if !os(darwin) && !os(windows) + ghc-Options: -pgml g++ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive" + +Executable fltkhs-browser + Main-Is: browser.hs + Hs-Source-Dirs: src/Examples + Build-Depends: + base == 4.*, + fltkhs >= 0.4.0.0, + bytestring + default-language: Haskell2010 + ghc-Options: -Wall -threaded + if impl(ghc >= 7.10) && flag(FastCompile) + ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0 + if os(windows) + ghc-Options: -optl-mwindows + if !os(darwin) && !os(windows) + ghc-Options: -pgml g++ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive" + +Executable fltkhs-clock + Main-Is: clock.hs + Hs-Source-Dirs: src/Examples + Build-Depends: + base == 4.*, + fltkhs >= 0.4.0.0, + bytestring + default-language: Haskell2010 + ghc-Options: -Wall -threaded + if impl(ghc >= 7.10) && flag(FastCompile) + ghc-Options: -fno-specialise -fmax-simplifier-iterations=0 -fsimplifier-phases=0 + if os(windows) + ghc-Options: -optl-mwindows + if !os(darwin) && !os(windows) + ghc-Options: -pgml g++ "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive" diff --git a/src/Examples/arc.hs b/src/Examples/arc.hs new file mode 100644 --- /dev/null +++ b/src/Examples/arc.hs @@ -0,0 +1,98 @@ +module Main where +import qualified Graphics.UI.FLTK.LowLevel.FL as FL +import Graphics.UI.FLTK.LowLevel.Fl_Types +import Graphics.UI.FLTK.LowLevel.Fl_Enumerations +import Graphics.UI.FLTK.LowLevel.FLTKHS +import Data.IORef +import Control.Monad + +name :: [String] +name = ["X", "Y", "R", "start", "end", "rotate"] + +drawArc :: IORef [Double] -> Ref Widget -> IO () +drawArc myArgsRef widget = do + myArgs <- readIORef myArgsRef + rectangle' <- getRectangle widget + let (x',y',w',h') = fromRectangle rectangle' + flcPushClip rectangle' + flcSetColor dark3Color + flcRectf rectangle' + flcPushMatrix + if (myArgs !! 5 > 0) + then do + flcTranslate + (ByXY + (ByX ((fromIntegral x') + (fromIntegral w')/2)) + (ByY ((fromIntegral y') + (fromIntegral h')/2))) + flcRotate (myArgs !! 5) + flcTranslate + (ByXY + (ByX (-((fromIntegral x') + (fromIntegral w')/2))) + (ByY (-((fromIntegral y') + (fromIntegral h')/2)))) + else return () + flcSetColor whiteColor + flcTranslate (ByXY (ByX (fromIntegral x')) (ByY (fromIntegral $ y'))) + flcBeginComplexPolygon + flcArcByRadius + (ByXY (ByX $ myArgs !! 0) (ByY $ myArgs !! 1)) + (myArgs !! 2) + (myArgs !! 3) + (myArgs !! 4) + flcGap + flcArcByRadius (ByXY (ByX 140) (ByY 140)) 20 0 (-360) + flcEndComplexPolygon + flcSetColor redColor + flcBeginLine + flcArcByRadius + (ByXY (ByX $ myArgs !! 0) (ByY $ myArgs !! 1)) + (myArgs !! 2) + (myArgs !! 3) + (myArgs !! 4) + flcEndLine + flcPopMatrix + flcPopClip + +setIndex :: Int -> [a] -> a -> [a] +setIndex idx' xs x = + map + ( + \(i,e) -> if (i == idx') + then x + else e + ) + (zip [0..] xs) + +sliderCb :: Ref Widget -> Int -> IORef [Double] -> Ref HorValueSlider -> IO () +sliderCb widget sliderNumber myArgsRef slider' = do + v' <- getValue slider' + modifyIORef myArgsRef (\myArgs' -> setIndex sliderNumber myArgs' v') + redraw widget + +main :: IO () +main = do + myArgs' <- newIORef [140, 140, 50, 0, 360,0] + window' <- doubleWindowNew (Size (Width 300) (Height 500)) Nothing Nothing + begin window' + widget <- widgetCustom + (Rectangle + (Position (X 10) (Y 10)) + (Size (Width 280) (Height 280))) + Nothing + (drawArc myArgs') + defaultCustomWidgetFuncs + forM_ (take 6 (zip (iterate ((+) 25) 300) [0..])) $ \(y, sliderNumber') -> do + s <- horValueSliderNew + (toRectangle $ (50, y, 240, 25)) + (Just $ name !! sliderNumber') + case sliderNumber' of + sliderNumber'' | sliderNumber'' < 3 -> setMinimum s 0 >> setMaximum s 300 + | sliderNumber'' == 5 -> setMinimum s 0 >> setMaximum s 360 + _ -> setMinimum s (-360) >> setMaximum s 360 + setStep s 1 + _ <- readIORef myArgs' >>= \args' -> setValue s (args' !! sliderNumber') + setAlign s alignLeft + setCallback s (sliderCb widget sliderNumber' myArgs') + end window' + showWidget window' + _ <- FL.run + return () diff --git a/src/Examples/bitmap.hs b/src/Examples/bitmap.hs new file mode 100644 --- /dev/null +++ b/src/Examples/bitmap.hs @@ -0,0 +1,151 @@ +module Main where +import qualified Graphics.UI.FLTK.LowLevel.FL as FL +import Graphics.UI.FLTK.LowLevel.Fl_Types +import Graphics.UI.FLTK.LowLevel.Fl_Enumerations +import Graphics.UI.FLTK.LowLevel.FLTKHS +import Data.IORef +import Control.Monad +import qualified Data.ByteString as B + +sorceressWidth :: Int +sorceressWidth = 75 + +sorceressHeight :: Int +sorceressHeight = 75 + +sorceressBits :: B.ByteString +sorceressBits = B.pack [ + 0xfc, 0x7e, 0x40, 0x20, 0x90, 0x00, 0x07, 0x80, 0x23, 0x00, 0x00, 0xc6, + 0xc1, 0x41, 0x98, 0xb8, 0x01, 0x07, 0x66, 0x00, 0x15, 0x9f, 0x03, 0x47, + 0x8c, 0xc6, 0xdc, 0x7b, 0xcc, 0x00, 0xb0, 0x71, 0x0e, 0x4d, 0x06, 0x66, + 0x73, 0x8e, 0x8f, 0x01, 0x18, 0xc4, 0x39, 0x4b, 0x02, 0x23, 0x0c, 0x04, + 0x1e, 0x03, 0x0c, 0x08, 0xc7, 0xef, 0x08, 0x30, 0x06, 0x07, 0x1c, 0x02, + 0x06, 0x30, 0x18, 0xae, 0xc8, 0x98, 0x3f, 0x78, 0x20, 0x06, 0x02, 0x20, + 0x60, 0xa0, 0xc4, 0x1d, 0xc0, 0xff, 0x41, 0x04, 0xfa, 0x63, 0x80, 0xa1, + 0xa4, 0x3d, 0x00, 0x84, 0xbf, 0x04, 0x0f, 0x06, 0xfc, 0xa1, 0x34, 0x6b, + 0x01, 0x1c, 0xc9, 0x05, 0x06, 0xc7, 0x06, 0xbe, 0x11, 0x1e, 0x43, 0x30, + 0x91, 0x05, 0xc3, 0x61, 0x02, 0x30, 0x1b, 0x30, 0xcc, 0x20, 0x11, 0x00, + 0xc1, 0x3c, 0x03, 0x20, 0x0a, 0x00, 0xe8, 0x60, 0x21, 0x00, 0x61, 0x1b, + 0xc1, 0x63, 0x08, 0xf0, 0xc6, 0xc7, 0x21, 0x03, 0xf8, 0x08, 0xe1, 0xcf, + 0x0a, 0xfc, 0x4d, 0x99, 0x43, 0x07, 0x3c, 0x0c, 0xf1, 0x9f, 0x0b, 0xfc, + 0x5b, 0x81, 0x47, 0x02, 0x16, 0x04, 0x31, 0x1c, 0x0b, 0x1f, 0x17, 0x89, + 0x4d, 0x06, 0x1a, 0x04, 0x31, 0x38, 0x02, 0x07, 0x56, 0x89, 0x49, 0x04, + 0x0b, 0x04, 0xb1, 0x72, 0x82, 0xa1, 0x54, 0x9a, 0x49, 0x04, 0x1d, 0x66, + 0x50, 0xe7, 0xc2, 0xf0, 0x54, 0x9a, 0x58, 0x04, 0x0d, 0x62, 0xc1, 0x1f, + 0x44, 0xfc, 0x51, 0x90, 0x90, 0x04, 0x86, 0x63, 0xe0, 0x74, 0x04, 0xef, + 0x31, 0x1a, 0x91, 0x00, 0x02, 0xe2, 0xc1, 0xfd, 0x84, 0xf9, 0x30, 0x0a, + 0x91, 0x00, 0x82, 0xa9, 0xc0, 0xb9, 0x84, 0xf9, 0x31, 0x16, 0x81, 0x00, + 0x42, 0xa9, 0xdb, 0x7f, 0x0c, 0xff, 0x1c, 0x16, 0x11, 0x00, 0x02, 0x28, + 0x0b, 0x07, 0x08, 0x60, 0x1c, 0x02, 0x91, 0x00, 0x46, 0x29, 0x0e, 0x00, + 0x00, 0x00, 0x10, 0x16, 0x11, 0x02, 0x06, 0x29, 0x04, 0x00, 0x00, 0x00, + 0x10, 0x16, 0x91, 0x06, 0xa6, 0x2a, 0x04, 0x00, 0x00, 0x00, 0x18, 0x24, + 0x91, 0x04, 0x86, 0x2a, 0x04, 0x00, 0x00, 0x00, 0x18, 0x27, 0x93, 0x04, + 0x96, 0x4a, 0x04, 0x00, 0x00, 0x00, 0x04, 0x02, 0x91, 0x04, 0x86, 0x4a, + 0x0c, 0x00, 0x00, 0x00, 0x1e, 0x23, 0x93, 0x04, 0x56, 0x88, 0x08, 0x00, + 0x00, 0x00, 0x90, 0x21, 0x93, 0x04, 0x52, 0x0a, 0x09, 0x80, 0x01, 0x00, + 0xd0, 0x21, 0x95, 0x04, 0x57, 0x0a, 0x0f, 0x80, 0x27, 0x00, 0xd8, 0x20, + 0x9d, 0x04, 0x5d, 0x08, 0x1c, 0x80, 0x67, 0x00, 0xe4, 0x01, 0x85, 0x04, + 0x79, 0x8a, 0x3f, 0x00, 0x00, 0x00, 0xf4, 0x11, 0x85, 0x06, 0x39, 0x08, + 0x7d, 0x00, 0x00, 0x18, 0xb7, 0x10, 0x81, 0x03, 0x29, 0x12, 0xcb, 0x00, + 0x7e, 0x30, 0x28, 0x00, 0x85, 0x03, 0x29, 0x10, 0xbe, 0x81, 0xff, 0x27, + 0x0c, 0x10, 0x85, 0x03, 0x29, 0x32, 0xfa, 0xc1, 0xff, 0x27, 0x94, 0x11, + 0x85, 0x03, 0x28, 0x20, 0x6c, 0xe1, 0xff, 0x07, 0x0c, 0x01, 0x85, 0x01, + 0x28, 0x62, 0x5c, 0xe3, 0x8f, 0x03, 0x4e, 0x91, 0x80, 0x05, 0x39, 0x40, + 0xf4, 0xc2, 0xff, 0x00, 0x9f, 0x91, 0x84, 0x05, 0x31, 0xc6, 0xe8, 0x07, + 0x7f, 0x80, 0xcd, 0x00, 0xc4, 0x04, 0x31, 0x06, 0xc9, 0x0e, 0x00, 0xc0, + 0x48, 0x88, 0xe0, 0x04, 0x79, 0x04, 0xdb, 0x12, 0x00, 0x30, 0x0c, 0xc8, + 0xe4, 0x04, 0x6d, 0x06, 0xb6, 0x23, 0x00, 0x18, 0x1c, 0xc0, 0x84, 0x04, + 0x25, 0x0c, 0xff, 0xc2, 0x00, 0x4e, 0x06, 0xb0, 0x80, 0x04, 0x3f, 0x8a, + 0xb3, 0x83, 0xff, 0xc3, 0x03, 0x91, 0x84, 0x04, 0x2e, 0xd8, 0x0f, 0x3f, + 0x00, 0x00, 0x5f, 0x83, 0x84, 0x04, 0x2a, 0x70, 0xfd, 0x7f, 0x00, 0x00, + 0xc8, 0xc0, 0x84, 0x04, 0x4b, 0xe2, 0x2f, 0x01, 0x00, 0x08, 0x58, 0x60, + 0x80, 0x04, 0x5b, 0x82, 0xff, 0x01, 0x00, 0x08, 0xd0, 0xa0, 0x84, 0x04, + 0x72, 0x80, 0xe5, 0x00, 0x00, 0x08, 0xd2, 0x20, 0x44, 0x04, 0xca, 0x02, + 0xff, 0x00, 0x00, 0x08, 0xde, 0xa0, 0x44, 0x04, 0x82, 0x02, 0x6d, 0x00, + 0x00, 0x08, 0xf6, 0xb0, 0x40, 0x02, 0x82, 0x07, 0x3f, 0x00, 0x00, 0x08, + 0x44, 0x58, 0x44, 0x02, 0x93, 0x3f, 0x1f, 0x00, 0x00, 0x30, 0x88, 0x4f, + 0x44, 0x03, 0x83, 0x23, 0x3e, 0x00, 0x00, 0x00, 0x18, 0x60, 0xe0, 0x07, + 0xe3, 0x0f, 0xfe, 0x00, 0x00, 0x00, 0x70, 0x70, 0xe4, 0x07, 0xc7, 0x1b, + 0xfe, 0x01, 0x00, 0x00, 0xe0, 0x3c, 0xe4, 0x07, 0xc7, 0xe3, 0xfe, 0x1f, + 0x00, 0x00, 0xff, 0x1f, 0xfc, 0x07, 0xc7, 0x03, 0xf8, 0x33, 0x00, 0xc0, + 0xf0, 0x07, 0xff, 0x07, 0x87, 0x02, 0xfc, 0x43, 0x00, 0x60, 0xf0, 0xff, + 0xff, 0x07, 0x8f, 0x06, 0xbe, 0x87, 0x00, 0x30, 0xf8, 0xff, 0xff, 0x07, + 0x8f, 0x14, 0x9c, 0x8f, 0x00, 0x00, 0xfc, 0xff, 0xff, 0x07, 0x9f, 0x8d, + 0x8a, 0x0f, 0x00, 0x00, 0xfe, 0xff, 0xff, 0x07, 0xbf, 0x0b, 0x80, 0x1f, + 0x00, 0x00, 0xff, 0xff, 0xff, 0x07, 0x7f, 0x3a, 0x80, 0x3f, 0x00, 0x80, + 0xff, 0xff, 0xff, 0x07, 0xff, 0x20, 0xc0, 0x3f, 0x00, 0x80, 0xff, 0xff, + 0xff, 0x07, 0xff, 0x01, 0xe0, 0x7f, 0x00, 0xc0, 0xff, 0xff, 0xff, 0x07, + 0xff, 0x0f, 0xf8, 0xff, 0x40, 0xe0, 0xff, 0xff, 0xff, 0x07, 0xff, 0xff, + 0xff, 0xff, 0x40, 0xf0, 0xff, 0xff, 0xff, 0x07, 0xff, 0xff, 0xff, 0xff, + 0x41, 0xf0, 0xff, 0xff, 0xff, 0x07 + ] + +data ToggleButtons = ToggleButtons { + leftb :: Ref ToggleButton, + rightb :: Ref ToggleButton, + topb :: Ref ToggleButton, + bottomb :: Ref ToggleButton, + insideb :: Ref ToggleButton, + overb :: Ref ToggleButton, + inactb :: Ref ToggleButton + } + +buttonCb :: IORef (ToggleButtons, Ref Button, Ref DoubleWindow) -> Ref ToggleButton -> IO () +buttonCb state' _ = + do + (toggleButtons', b, win) <- readIORef state' + i <- newIORef [] + let addIf :: (ToggleButtons -> Ref ToggleButton) -> AlignType -> IO () + addIf b' alignType' = do + v' <- getValue (b' toggleButtons') + when v' (modifyIORef i ((++) [alignType'])) + addIf leftb AlignTypeLeft + addIf rightb AlignTypeRight + addIf topb AlignTypeTop + addIf bottomb AlignTypeBottom + addIf insideb AlignTypeInside + addIf overb AlignTypeTextOverImage + readIORef i >>= setAlign b . Alignments + inactbValue <- getValue (inactb toggleButtons') + if inactbValue then deactivate b + else activate b + redraw win + +main :: IO () +main = do + window <- doubleWindowNew (Size (Width 400) (Height 400)) Nothing Nothing + begin window + button <- buttonNew + (Rectangle + (Position (X 140) (Y 160)) + (Size (Width 120) (Height 120))) + (Just "Bitmap") + bitmap <- bitmapNew + (BitmapHs + sorceressBits + (Size + (Width sorceressWidth) + (Height sorceressHeight))) + setImage button (Just bitmap) + leftb' <- toggleButtonNew (Rectangle (Position (X 25) (Y 50)) (Size (Width 50) (Height 25))) (Just "left") + rightb' <- toggleButtonNew (Rectangle (Position (X 75) (Y 50)) (Size (Width 50) (Height 25))) (Just "right") + topb' <- toggleButtonNew (Rectangle (Position (X 125) (Y 50)) (Size (Width 50) (Height 25))) (Just "top") + bottomb' <- toggleButtonNew (Rectangle (Position (X 175) (Y 50)) (Size (Width 50) (Height 25))) (Just "bottom") + insideb' <- toggleButtonNew (Rectangle (Position (X 225) (Y 50)) (Size (Width 50) (Height 25))) (Just "inside") + overb' <- toggleButtonNew (Rectangle (Position (X 25) (Y 75)) (Size (Width 100) (Height 25))) (Just "text over") + inactb' <- toggleButtonNew (Rectangle (Position (X 125) (Y 75)) (Size (Width 100) (Height 25))) (Just "inactive") + state' <- newIORef ((ToggleButtons leftb' rightb' topb' bottomb' insideb' overb' inactb'), + button, + window) + setCallback leftb' $ buttonCb state' + setCallback rightb' $ buttonCb state' + setCallback topb' $ buttonCb state' + setCallback bottomb' $ buttonCb state' + setCallback insideb' $ buttonCb state' + setCallback overb' $ buttonCb state' + setCallback inactb' $ buttonCb state' + setResizable window (Just window) + end window + showWidget window + _ <- FL.run + return () diff --git a/src/Examples/boxtype.hs b/src/Examples/boxtype.hs new file mode 100644 --- /dev/null +++ b/src/Examples/boxtype.hs @@ -0,0 +1,97 @@ +module Main where +import qualified Graphics.UI.FLTK.LowLevel.FL as FL +import Graphics.UI.FLTK.LowLevel.Fl_Types +import Graphics.UI.FLTK.LowLevel.Fl_Enumerations +import Graphics.UI.FLTK.LowLevel.FLTKHS +import Data.IORef +import Control.Monad + +windowWidth :: Int +windowWidth = 200 +rowHeight :: Int +rowHeight = 50 +numRows :: Int +numRows = 14 +bt :: IORef Int -> String -> Boxtype -> Bool -> IO () +bt n label' boxtype' square' = do + n' <- readIORef n + let (quotient',remainder') = quotRem n' 4 + modifyIORef n (+ 1) + b' <- boxNewWithBoxtype + boxtype' + (Rectangle + (Position (X (remainder' * windowWidth + 10)) (Y (quotient' * rowHeight + 10))) + (Size + (Width $ if square' then rowHeight - 20 else windowWidth - 20) + (Height $ rowHeight - 20))) + label' + setLabelsize b' (FontSize 11) + when square' $ setAlign b' alignRight +main :: IO () +main = do + window <- doubleWindowNew + (Size (Width $ windowWidth * 4) (Height $ numRows * rowHeight)) + Nothing + Nothing + setBox window FlatBox + FL.getSystemColors + setColor window (Color 12) + n' <- newIORef 0 + begin window + bt n' "NoBox" NoBox False + bt n' "FlatBox" FlatBox False + modifyIORef n' (+ 2) + bt n' "UpBox" UpBox False + bt n' "DownBox" DownBox False + bt n' "UpFrame" UpFrame False + bt n' "DownFrame" DownFrame False + bt n' "ThinUpBox" ThinUpBox False + bt n' "ThinDownBox" ThinDownBox False + bt n' "ThinUpFrame" ThinUpFrame False + bt n' "ThinDownFrame" ThinDownFrame False + bt n' "EngravedBox" EngravedBox False + bt n' "EmbossedBox" EmbossedBox False + bt n' "EngravedFrame" EngravedFrame False + bt n' "EmbossedFrame" EmbossedFrame False + bt n' "BorderBox" BorderBox False + bt n' "ShadowBox" ShadowBox False + bt n' "BorderFrame" BorderFrame False + bt n' "ShadowFrame" ShadowFrame False + bt n' "RoundedBox" RoundedBox False + bt n' "RshadowBox" RshadowBox False + bt n' "RoundedFrame" RoundedFrame False + bt n' "RFlatBox" RFlatBox False + bt n' "RoundUpBox" RoundUpBox False + bt n' "RoundDownBox" RoundDownBox False + bt n' "DiamondUpBox" DiamondUpBox False + bt n' "DiamondDownBox" DiamondDownBox False + bt n' "OvalBox" OvalBox False + bt n' "OshadowBox" OshadowBox False + bt n' "OvalFrame" OvalFrame False + bt n' "FloatBox" FloatBox False + bt n' "PlasticUpBox" PlasticUpBox False + bt n' "PlasticDownBox" PlasticDownBox False + bt n' "PlasticUpFrame" PlasticUpFrame False + bt n' "PlasticDownFrame" PlasticDownFrame False + bt n' "PlasticThinUpBox" PlasticThinUpBox False + bt n' "PlasticThinDownBox" PlasticThinDownBox False + modifyIORef n' (+ 2) + bt n' "PlasticRoundUpBox" PlasticRoundUpBox False + bt n' "PlasticRoundDownBox" PlasticRoundDownBox False + modifyIORef n' (+ 2) + bt n' "GtkUpBox" GtkUpBox False + bt n' "GtkDownBox" GtkDownBox False + bt n' "GtkUpFrame" GtkUpFrame False + bt n' "GtkDownFrame" GtkDownFrame False + bt n' "GtkThinUpBox" GtkThinUpBox False + bt n' "GtkThinDownBox" GtkThinDownBox False + bt n' "GtkThinUpFrame" GtkThinUpFrame False + bt n' "GtkThinDownFrame" GtkThinDownFrame False + bt n' "GtkRoundUpBox" GtkRoundUpBox False + bt n' "GtkRoundDownBox" GtkRoundDownBox False + bt n' "FreeBoxtype" FreeBoxtype False + setResizable window (Just window) + end window + showWidget window + _ <- FL.run + return () diff --git a/src/Examples/browser.hs b/src/Examples/browser.hs new file mode 100644 --- /dev/null +++ b/src/Examples/browser.hs @@ -0,0 +1,127 @@ +{- +This is a test of how the browser draws lines. +This is a second line. +This is a third. + +That was a blank line above this. + +@r@_Right justify +@c@_Center justify +@_Left justify + +@bBold text +@iItalic text +@b@iBold Italic +@fFixed width +@f@bBold Fixed +@f@iItalic Fixed +@f@i@bBold Italic Fixed +@lLarge +@l@bLarge bold +@sSmall +@s@bSmall bold +@s@iSmall italic +@s@i@bSmall italic bold +@uunderscore +@C1RED +@C2Green +@C4Blue + + You should try different browser types: + Fl_Browser + Fl_Select_Browser + Fl_Hold_Browser + Fl_Multi_Browser +-} + +module Main where +import qualified Graphics.UI.FLTK.LowLevel.FL as FL +import Graphics.UI.FLTK.LowLevel.FLTKHS +import Control.Monad +import System.Environment + +data CallbackType = Top | Middle | Bottom | Visible | Browser +bCb :: Ref SelectBrowser -> IO () +bCb browser' = FL.eventClicks >>= setValue browser' + +showCb :: CallbackType -> Ref IntInput -> Ref SelectBrowser -> IO () +showCb buttontype' field' browser' = do + line' <- getValue field' + if (null line') + then print "Please enter a number in the text field before clicking on the buttons." + else do + let lineNumber' = read line' + case buttontype' of + Top -> setTopline browser' lineNumber' + Bottom -> setBottomline browser' lineNumber' + Middle -> setMiddleline browser' lineNumber' + _ -> makeVisible browser' lineNumber' + +swapCb :: Ref SelectBrowser -> Ref Button -> IO () +swapCb browser' _ = + do + browserSize' <- getSize browser' + linesSelected' <- filterM (selected browser') [0..(browserSize' - 1)] + case linesSelected' of + (l1:l2:_) -> swap browser' l1 l2 + (l1:[]) -> swap browser' l1 (-1) + _ -> swap browser' (-1) (-1) + +sortCb :: Ref SelectBrowser -> Ref Button -> IO () +sortCb browser' _ = sortWithSortType browser' SortAscending + +btypeCb :: Ref SelectBrowser -> Ref Choice -> IO () +btypeCb browser' btype' = do + numLines' <- getSize browser' + forM_ [1..(numLines' - 1)] (\l -> select browser' l False) + _ <- select browser' 1 False -- leave focus box on first line + choice' <- getText btype' + case choice' of + "Normal" -> setType browser' NormalBrowserType + "Select" -> setType browser' SelectBrowserType + "Hold" -> setType browser' HoldBrowserType + "Multi" -> setType browser' MultiBrowserType + _ -> return () + redraw browser' + +main :: IO () +main = do + args <- getArgs + if (null args) then print "Enter the path to a text file as an argument. As an example use this file (./src/Examples/browser.hs) to see what Fl_Browser can do." + else do + let fname = head args + window <- doubleWindowNew (Size (Width 560) (Height 400)) Nothing (Just fname) + browser' <- selectBrowserNew (Rectangle (Position (X 0) (Y 0)) (Size (Width 560) (Height 350))) Nothing + setType browser' MultiBrowserType + setCallback browser' bCb + loadStatus' <- load browser' fname + if (loadStatus' == 0) + then print ("Can't load " ++ fname) + else do + setPosition browser' 0 + field <- intInputNew (toRectangle (55,350,505,25)) (Just "Line #:") + setCallback field (\_ -> showCb Browser field browser') + top' <- buttonNew (toRectangle (0,375,80,25)) (Just "Top") + setCallback top' (\_ -> showCb Top field browser') + bottom' <- buttonNew (toRectangle (80,375,80,25)) (Just "Bottom") + setCallback bottom' (\_ -> showCb Bottom field browser') + middle' <- buttonNew (toRectangle (160,375,80,25)) (Just "Middle") + setCallback middle' (\_ -> showCb Middle field browser') + visible' <- buttonNew (toRectangle (240,375,80,25)) (Just "Make Vis.") + setCallback visible' (\_ -> showCb Visible field browser') + swap' <- buttonNew (toRectangle (320,375,80,25)) (Just "Swap") + setCallback swap' $ swapCb browser' + setTooltip swap' "Swaps two selected lines\n(Use CTRL-click to select two lines)" + sort' <- buttonNew (toRectangle (400,375,80,25)) (Just "Sort") + setCallback sort' (sortCb browser') + btype <- choiceNew (toRectangle (480,375,80,25)) Nothing + addName btype "Normal" + addName btype "Select" + addName btype "Hold" + addName btype "Multi" + setCallback btype $ btypeCb browser' + _ <- setValue btype (MenuItemByIndex (MenuItemIndex 3)) + setResizable window (Just browser') + showWidget window + _ <- FL.run + return () diff --git a/src/Examples/clock.hs b/src/Examples/clock.hs new file mode 100644 --- /dev/null +++ b/src/Examples/clock.hs @@ -0,0 +1,22 @@ +module Main where +import qualified Graphics.UI.FLTK.LowLevel.FL as FL +import Graphics.UI.FLTK.LowLevel.FLTKHS + +main :: IO () +main = do + w1 <- doubleWindowNew (Size (Width 220) (Height 220)) Nothing (Just "clock") + begin w1 + c1 <- clockNew (toRectangle (0,0,220,220)) Nothing + setResizable w1 (Just c1) + end w1 + w2 <- doubleWindowNew (Size (Width 220) (Height 220)) Nothing (Just "Rounded Clock") + begin w2 + c2 <- clockNew (toRectangle (0,0,220,220)) Nothing + setResizable w2 (Just c2) + end w2 + setXclass w1 "Fl_Clock" + setXclass w2 "Fl_Clock" + showWidget w1 + showWidget w2 + _ <- FL.run + return () diff --git a/src/Examples/doublebuffer.hs b/src/Examples/doublebuffer.hs new file mode 100644 --- /dev/null +++ b/src/Examples/doublebuffer.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-} +module Main where +import qualified Graphics.UI.FLTK.LowLevel.FL as FL +import Graphics.UI.FLTK.LowLevel.Fl_Enumerations +import Graphics.UI.FLTK.LowLevel.Fl_Types +import Graphics.UI.FLTK.LowLevel.FLTKHS +import Control.Monad +import Data.IORef + +star :: Int -> Int -> Double -> IO () +star w h n = do + flcPushMatrix + flcTranslate (ByXY (ByX (fromIntegral w / 2)) (ByY (fromIntegral h /2))) + flcScaleWithY (ByXY (ByX (fromIntegral w / 2)) (ByY (fromIntegral h /2))) + forM_ [0..n] $ \i -> do + forM_ [(i+1)..n] $ \j -> do + let i_vertex :: Double = 2 * pi * i/n + 0.1 + j_vertex :: Double = 2 * pi * j/n + 0.1 + flcBeginLine + flcVertex (ByXY (ByX $ cos i_vertex) (ByY $ sin i_vertex)) + flcVertex (ByXY (ByX $ cos j_vertex) (ByY $ sin j_vertex)) + flcEndLine + flcPopMatrix + +sliderCb :: IORef (Double,Double) -> (Double -> (Double,Double) -> (Double,Double))-> Ref HorSlider -> IO () +sliderCb sides' sidesf' slider' = do + v' <- getValue slider' + modifyIORef sides' (sidesf' v') + (Just p') <- getParent slider' + redraw p' + +badDraw :: IORef (Double,Double) -> Int -> Int -> ((Double,Double) -> Double) -> IO () +badDraw sides w h which' = do + flcSetColor blackColor >> flcRectf (toRectangle (0,0,w,h)) + flcSetColor whiteColor >> readIORef sides >>= star w h . which' + + +drawWindow :: IORef (Double, Double) -> + ((Double, Double) -> Double) -> + Ref Window -> + IO () +drawWindow sides' whichf' w' = do + ww' <- getW w' + wh' <- getH w' + badDraw sides' ww' wh' whichf' + c' <- getChild w' (0 :: Int) + maybe (return ()) (drawChild w') (c' :: Maybe (Ref Widget)) + +main :: IO () +main = do + visual' <- FL.visual ModeDouble + if (not visual') then print "Xdbe not supported, faking double buffer with pixmaps.\n" else return () + sides' <- newIORef (20,20) + w01 <- windowNew (toSize (420,420)) Nothing (Just "Fl_Single_Window") + setBox w01 FlatBox + begin w01 + w1 <- singleWindowCustom + (Size (Width 400) (Height 400)) + (Just (Position (X 10) (Y 10))) + (Just "Single Window") + (Just (\w -> drawWindow sides' fst (safeCast w))) + defaultCustomWidgetFuncs + defaultCustomWindowFuncs + setBox w1 FlatBox + setColor w1 blackColor + setResizable w1 (Just w1) + begin w1 + slider0 <- horSliderNew (toRectangle (20,370,360,25)) Nothing + range slider0 2 30 + setStep slider0 1 + _ <- readIORef sides' >>= setValue slider0 . fst + setCallback slider0 (sliderCb sides' (\v (_,s2) -> (v, s2))) + end w1 + end w01 + w02 <- windowNew (Size (Width 420) (Height 420)) Nothing (Just "Fl_Double_Window") + setBox w02 FlatBox + begin w02 + w2 <- doubleWindowCustom + (Size (Width 400) (Height 400)) + (Just $ Position (X 10) (Y 10)) + (Just "Fl_Double_Window") + (Just (\w -> drawWindow sides' snd (safeCast w))) + defaultCustomWidgetFuncs + defaultCustomWindowFuncs + setBox w2 FlatBox + setColor w2 blackColor + setResizable w2 (Just w2) + begin w2 + slider1 <- horSliderNew (toRectangle $ (20,370,360,25)) Nothing + range slider1 2 30 + setStep slider1 1 + _ <- readIORef sides' >>= setValue slider1 . fst + setCallback slider1 (sliderCb sides' (\v (s1,_) -> (s1,v))) + end w2 + end w02 + showWidget w01 + showWidget w1 + showWidget w02 + showWidget w2 + _ <- FL.run + return () diff --git a/src/Examples/make-tree.hs b/src/Examples/make-tree.hs new file mode 100644 --- /dev/null +++ b/src/Examples/make-tree.hs @@ -0,0 +1,21 @@ +module Main where +import qualified Graphics.UI.FLTK.LowLevel.FL as FL +import Graphics.UI.FLTK.LowLevel.Fl_Types +import Graphics.UI.FLTK.LowLevel.FLTKHS +import Control.Monad + +main :: IO () +main = do + win' <- windowNew (Size (Width 500) (Height 500)) Nothing (Just "FLTK Tree Window") + begin win' + tree' <- treeNew (toRectangle (50,50,200,200)) (Just "Tree") + rootLabel tree' "Root Label With Items" + prefs' <- treePrefsNew + forM_ [0..(9 :: Int)] $ \_ -> do + item' <- treeItemNew prefs' + setLabel item' "test" + addAt tree' "test" item' + end win' + showWidget win' + _ <- FL.run + return () diff --git a/src/Examples/nativefilechooser-simple-app.hs b/src/Examples/nativefilechooser-simple-app.hs new file mode 100644 --- /dev/null +++ b/src/Examples/nativefilechooser-simple-app.hs @@ -0,0 +1,92 @@ +module Main where +import qualified Graphics.UI.FLTK.LowLevel.FL as FL +import Graphics.UI.FLTK.LowLevel.Fl_Types +import Graphics.UI.FLTK.LowLevel.Fl_Enumerations +import Graphics.UI.FLTK.LowLevel.FLTKHS +import System.Directory +import System.Exit + +openFile :: FilePath -> IO () +openFile fp = print $ "Open '" ++ fp ++ "''" + +saveFile :: FilePath -> IO () +saveFile fp = do + print $ "Saving '" ++ fp ++ "'" + exists' <- doesFileExist fp + if not exists' + then writeFile fp "Hello world.\n" + else return () + +openCb :: Ref NativeFileChooser -> Ref MenuItem -> IO () +openCb fc _ = do + setTitle fc "Open" + res' <- showWidget fc + case res' of + NativeFileChooserPicked -> do + f' <- getFilename fc + case f' of + (Just f'') -> do + setPresetFile fc f'' + openFile f'' + _ -> return () + _ -> return () + +saveAsCb :: Ref NativeFileChooser -> Ref MenuItem -> IO () +saveAsCb fc _ = do + setTitle fc "Open" + res' <- showWidget fc + case res' of + NativeFileChooserPicked -> do + f' <- getFilename fc + case f' of + (Just f'') -> do + setPresetFile fc f'' + saveFile f'' + _ -> return () + _ -> return () + +saveCb :: Ref NativeFileChooser -> Ref MenuItem -> IO () +saveCb fc w' = do + f' <- getFilename fc + case f' of + Nothing -> saveAsCb fc w' + (Just f'') -> saveFile f'' + +quitCb :: Ref MenuItem -> IO () +quitCb _ = exitSuccess + +initializeWindow :: Ref Window -> IO () +initializeWindow w' = do + chooser <- nativeFileChooserNew Nothing + setFilter chooser "Text\t*.txt\n" + setPresetFile chooser "untitiled.txt" + begin w' + menu <- sysMenuBarNew (toRectangle (0,0,400,25)) Nothing + _ <- add menu "&File/&Open" (Just (KeySequence (ShortcutKeySequence [kb_CommandState] (NormalKeyType 'o')))) (Just (openCb chooser)) (MenuItemFlags []) + _ <- add menu "&File/&Save" (Just (KeySequence (ShortcutKeySequence [kb_CommandState] (NormalKeyType 's')))) (Just (saveCb chooser)) (MenuItemFlags []) + _ <- add menu "&File/&Save As" Nothing (Just (saveAsCb chooser)) (MenuItemFlags []) + _ <- add menu "&File/&Quit" (Just (KeySequence (ShortcutKeySequence [kb_CommandState] (NormalKeyType 'q')))) (Just quitCb) (MenuItemFlags []) + w_w' <- getW w' + w_h' <- getH w' + box' <- boxNew (toRectangle (20,25+20,w_w'-40,w_h'-40-25)) Nothing + setColor box' (Color 45) + setBox box' FlatBox + setAlign box' (Alignments [AlignTypeCenter, AlignTypeInside, AlignTypeWrap]) + setLabel box' $ "This demo shows an example of implementing " ++ + "common 'File' menu operations like:\n" ++ + " File/Open, File/Save, File/Save As\n" ++ + "..using the Fl_Native_File_Chooser widget.\n\n" ++ + "Note 'Save' and 'Save As' really *does* create files! " ++ + "This is to show how behavior differs when " ++ + "files exist vs. do not."; + setLabelsize box' (FontSize 12) + end w' + +main :: IO () +main = do + _ <- FL.setScheme "gtk+" + app <- windowNew (toSize (400,200)) Nothing (Just "Native File Chooser Example") + initializeWindow app + showWidget app + _ <- FL.run + return () diff --git a/src/Examples/pack.hs b/src/Examples/pack.hs new file mode 100644 --- /dev/null +++ b/src/Examples/pack.hs @@ -0,0 +1,73 @@ +module Main where +import qualified Graphics.UI.FLTK.LowLevel.FL as FL +import Graphics.UI.FLTK.LowLevel.Fl_Enumerations +import Graphics.UI.FLTK.LowLevel.Fl_Types +import Graphics.UI.FLTK.LowLevel.FLTKHS + +type_cb :: Ref Scrolled -> Ref Pack -> PackType -> Ref LightButton -> IO () +type_cb scrolled pack packType _ = do + cs <- getArray pack + mapM_ (\c -> resize c (toRectangle (0,0,25,25))) cs + rect <- getRectangle scrolled + resize pack rect + getParent pack >>= + maybe (return ()) + (\p' -> redraw p' >> setType pack packType >> redraw pack) + +spacing_cb :: Ref Scrolled -> Ref Pack -> Ref HorValueSlider -> IO () +spacing_cb scrolled pack slider = do + spacing <- getValue slider + setSpacing pack (truncate spacing) + redraw scrolled + +main :: IO () +main = do + w <- doubleWindowNew (Size (Width 360) (Height 370)) Nothing Nothing + scrolled <- scrolledNew (toRectangle (10,10,340,285)) Nothing + begin scrolled + pack <- packNew (toRectangle $ (10,10,340,285)) Nothing + setBox pack DownFrame + begin pack + _ <- buttonNew (toRectangle (35, 35, 25, 25)) (Just "b1") + _ <- buttonNew (toRectangle (45, 45, 25, 25)) (Just "b2") + _ <- buttonNew (toRectangle (55, 55, 25, 25)) (Just "b3") + _ <- buttonNew (toRectangle (65, 65, 25, 25)) (Just "b4") + _ <- buttonNew (toRectangle (75, 75, 25, 25)) (Just "b5") + _ <- buttonNew (toRectangle (85, 85, 25, 25)) (Just "b6") + _ <- buttonNew (toRectangle (95, 95, 25, 25)) (Just "b7") + _ <- buttonNew (toRectangle (105, 105, 25, 25)) (Just "b8") + _ <- buttonNew (toRectangle (115, 115, 25, 25)) (Just "b9") + _ <- buttonNew (toRectangle (125, 125, 25, 25)) (Just "b10") + _ <- buttonNew (toRectangle (135, 135, 25, 25)) (Just "b11") + _ <- buttonNew (toRectangle (145, 145, 25, 25)) (Just "b12") + _ <- buttonNew (toRectangle (155, 155, 25, 25)) (Just "b13") + _ <- buttonNew (toRectangle (165, 165, 25, 25)) (Just "b14") + _ <- buttonNew (toRectangle (175, 175, 25, 25)) (Just "b15") + _ <- buttonNew (toRectangle (185, 185, 25, 25)) (Just "b16") + _ <- buttonNew (toRectangle (195, 195, 25, 25)) (Just "b17") + _ <- buttonNew (toRectangle (205, 205, 25, 25)) (Just "b18") + _ <- buttonNew (toRectangle (215, 215, 25, 25)) (Just "b19") + _ <- buttonNew (toRectangle (225, 225, 25, 25)) (Just "b20") + _ <- buttonNew (toRectangle (235, 235, 25, 25)) (Just "b21") + _ <- buttonNew (toRectangle (245, 245, 25, 25)) (Just "b22") + _ <- buttonNew (toRectangle (255, 255, 25, 25)) (Just "b23") + _ <- buttonNew (toRectangle (265, 265, 25, 25)) (Just "b24") + end pack + setResizable w (Just w) + end scrolled + lb1 <- lightButtonNew (toRectangle (10, 305, 165, 25)) (Just "HORIZONTAL") + setType lb1 RadioButtonType + setCallback lb1 (type_cb scrolled pack PackHorizontal) + lb2 <- lightButtonNew (toRectangle(185, 305, 165, 25)) (Just "VERTICAL") + setType lb2 RadioButtonType + _ <- setValue lb2 True + setCallback lb2 (type_cb scrolled pack PackVertical) + vs <- horValueSliderNew (toRectangle (100, 335, 250, 25)) (Just "Spacing: ") + setAlign vs (Alignments [AlignTypeLeft]) + range vs 0 30 + setStep vs 1 + setCallback vs (spacing_cb scrolled pack) + end w + showWidget w + _ <- FL.run + return () diff --git a/src/Examples/table-as-container.hs b/src/Examples/table-as-container.hs new file mode 100644 --- /dev/null +++ b/src/Examples/table-as-container.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Main where +import qualified Graphics.UI.FLTK.LowLevel.FL as FL +import Graphics.UI.FLTK.LowLevel.Fl_Types +import Graphics.UI.FLTK.LowLevel.Fl_Enumerations +import Graphics.UI.FLTK.LowLevel.FLTKHS + +buttonCb :: Ref LightButton -> IO () +buttonCb lightButton = do + l' <- getLabel lightButton + print $ "BUTTON: " ++ l' + +setTableSize :: Ref Table -> Int -> Int -> IO () +setTableSize t' nr' nc' = do + clear t' + setRows t' nr' + setCols t' nc' + begin t' + let (rowCols :: [(Int,Int)]) = [(r',c') | r' <- [0..(nr'-1)], c' <- [0..(nc'-1)]] + mapM_ + (\(_r,_c) -> do + cellRectangle <- findCell t' ContextTable (TableCoordinate (Row _r) (Column _c)) + case cellRectangle of + Just cellRectangle' -> + if (odd _c) + then do + let s = (show _r) ++ "." ++ (show _c) + input_ <- inputNew cellRectangle' Nothing Nothing + _ <- setValue input_ s Nothing + return () + else + do + let s = (show _r) ++ "/" ++ (show _c) + butt <- lightButtonNew cellRectangle' (Just s) + setAlign butt (Alignments [AlignTypeCenter, AlignTypeInside]) + setCallback butt buttonCb + _ <- setValue butt ((_r+_c*2) `mod` 4 == 0) + return () + Nothing -> return () + ) + rowCols + end t' + +drawCell :: Ref Table -> TableContext -> TableCoordinate -> Rectangle -> IO () +drawCell t' tcontext' (TableCoordinate (Row tr') (Column tc')) r' = + case tcontext' of + ContextStartPage -> flcSetFont helvetica (FontSize 12) + ContextRCResize -> do + rows' <- getRows t' + cols' <- getCols t' + let (rowCols :: [(Int,Int)]) = [(_r,_c) | _r <- [0..(rows'-1)], _c <- [0..(cols'-1)]] + mapM_ + (\((i::Int), (_r',_c')) -> do + children' <- children t' + if (i >= children') + then return () + else do + cellRectangle <- findCell t' ContextTable (TableCoordinate (Row _r') (Column _c')) + case cellRectangle of + Just cellRectangle' -> do + child' <- getChild t' i + maybe (return ()) (\c -> resize c cellRectangle') child' + Nothing -> return () + ) + (zip [0..] rowCols) + initSizes t' + ContextRowHeader -> do + flcPushClip r' + let s = "Row " ++ (show tr') + headerColor <- getRowHeaderColor t' + flcDrawBox ThinUpBox r' headerColor + flcSetColor blackColor + flcDrawInBox s r' (Alignments [AlignTypeCenter]) Nothing Nothing + flcPopClip + ContextColHeader -> do + flcPushClip r' + let s = "Column " ++ (show tc') + headerColor <- getColHeaderColor t' + flcDrawBox ThinUpBox r' headerColor + flcSetColor blackColor + flcDrawInBox s r' (Alignments [AlignTypeCenter]) Nothing Nothing + flcPopClip + _ -> return () +initializeTable :: Ref Table -> IO () +initializeTable t = do + begin t + setColHeader t True + setColResize t True + setColHeaderHeight t 25 + setRowHeader t True + setRowResize t True + setRowHeaderWidth t 80 + end t +main :: IO () +main = do + win <- doubleWindowNew (toSize (940,500)) Nothing (Just "table as container") + win_w <- getW win + win_h <- getH win + begin win + table <- tableCustom + (toRectangle (20,20,win_w-40,win_h-40)) + (Just "FLTK widget table") + Nothing + drawCell + defaultCustomWidgetFuncs + defaultCustomTableFuncs + initializeTable table + setTableSize table 50 50 + end win + setResizable win (Just table) + showWidget win + _ <- FL.run + return () diff --git a/src/Examples/table-simple.hs b/src/Examples/table-simple.hs new file mode 100644 --- /dev/null +++ b/src/Examples/table-simple.hs @@ -0,0 +1,78 @@ +module Main where +import qualified Graphics.UI.FLTK.LowLevel.FL as FL +import Graphics.UI.FLTK.LowLevel.FLTKHS +import Graphics.UI.FLTK.LowLevel.Fl_Enumerations + +maxRows :: Int +maxRows = 30 +maxCols :: Int +maxCols = 26 +tableData :: [[Int]] +tableData = + let rowIndices = [0 .. (maxRows - 1)] + colIndices = [0 .. (maxCols - 1)] + in + map (\r -> map (\c -> 1000 + (r * 1000) + c) colIndices) rowIndices +drawHeader :: Ref Table -> String -> Rectangle -> IO () +drawHeader table s rectangle = do + flcPushClip rectangle + rhc <- getRowHeaderColor table + flcDrawBox ThinUpBox rectangle rhc + flcSetColor blackColor + flcDrawInBox s rectangle alignCenter Nothing Nothing + flcPopClip +drawData :: Ref Table -> String -> Rectangle -> IO () +drawData table s rectangle = do + flcPushClip rectangle + flcSetColor whiteColor >> flcRectf rectangle + flcSetColor gray0Color >> flcDrawInBox s rectangle alignCenter Nothing Nothing + color' <- getColor table + flcSetColor color' >> flcRect rectangle + flcPopClip +drawCell :: Ref Table -> TableContext -> TableCoordinate -> Rectangle -> IO () +drawCell table context (TableCoordinate (Row row) (Column col)) rectangle = do + case context of + ContextStartPage -> flcSetFont helvetica (FontSize 16) + ContextColHeader -> + let a = fromEnum 'A' + currentLetter :: Char + currentLetter = (toEnum $ fromEnum a + col) + in + drawHeader table [currentLetter] rectangle + ContextRowHeader -> drawHeader table (show row) rectangle + ContextCell -> drawData table (show $ tableData !! row !! col) rectangle + _ -> return () +initializeTable :: Ref Table -> IO () +initializeTable table = do + begin table + setRows table maxRows + setRowHeader table True + setRowHeightAll table 20 + setRowResize table False + setCols table maxCols + setColHeader table True + setColWidthAll table 80 + setColResize table True + end table +main :: IO () +main = do + window <- doubleWindowNew + (Size (Width 900) (Height 400)) + Nothing + (Just "Simple Table") + begin window + table <- tableCustom + (Rectangle + (Position (X 10) (Y 10)) + (Size (Width 880) (Height 380))) + Nothing + Nothing + drawCell + defaultCustomWidgetFuncs + defaultCustomTableFuncs + initializeTable table + setResizable window (Just table) + end window + showWidget window + _ <- FL.run + return () diff --git a/src/Examples/table-sort.hs b/src/Examples/table-sort.hs new file mode 100644 --- /dev/null +++ b/src/Examples/table-sort.hs @@ -0,0 +1,241 @@ +{-# LANGUAGE CPP #-} +module Main where +import qualified Graphics.UI.FLTK.LowLevel.FL as FL +import Graphics.UI.FLTK.LowLevel.Fl_Enumerations +import Graphics.UI.FLTK.LowLevel.Fl_Types +import Control.Monad +import Graphics.UI.FLTK.LowLevel.FLTKHS +import Data.IORef +import Data.List +import Data.Function +import System.Process +dirCommand :: ([Char], [[Char]]) +dirHeaders :: [[Char]] +#ifdef mingw32_HOST_OS +dirCommand = ("dir", []) +dirHeaders = ["Perms", "#L", "Own", "Group", "Size", "Date", "", "", "Filename"] +#else +dirCommand = ("ls", ["-l"]) +dirHeaders = ["Date", "Time", "Size", "Filename", "", "", "", "", ""] +#endif +margin :: Int +margin = 20 +headerFontFace :: Font +headerFontFace = helveticaBold +headerFontSize :: FontSize +headerFontSize = FontSize 16 +rowFontFace :: Font +rowFontFace = helvetica +rowFontSize :: FontSize +rowFontSize = FontSize 16 + +data TableState = TableState { + sortReverse :: IORef Bool, + sortLastCol :: IORef Int, + rowData :: IORef [[String]] + } + +drawSortArrow :: Rectangle -> Bool -> IO () +drawSortArrow (Rectangle (Position (X x') (Y y')) (Size (Width w') (Height h'))) sortReverse' = + let xlft = x' + (w'-6) - 8 + xctr = x' + (w'-6) - 4 + xrit = x' + (w'-6) - 0 + ytop = y' + (truncate ((fromIntegral h' / 2) :: Double)) - 4 + ybot = y' + (truncate ((fromIntegral h' / 2) :: Double)) + 4 + in + if sortReverse' + then do + flcSetColor whiteColor + flcLine (Position (X xrit) (Y ytop)) (Position (X xctr) (Y ybot)) + flcSetColorWithC 41 + flcLine (Position (X xlft) (Y ytop)) (Position (X xrit) (Y ytop)) + flcLine (Position (X xlft) (Y ytop)) (Position (X xctr) (Y ybot)) + else do + flcSetColor whiteColor + flcLine (Position (X xrit) (Y ybot)) (Position (X xctr) (Y ybot)) + flcLine (Position (X xrit) (Y ybot)) (Position (X xlft) (Y ybot)) + flcSetColorWithC 41 + flcLine (Position (X xlft) (Y ybot)) (Position (X xctr) (Y ytop)) + +drawCell :: TableState -> Ref TableRow -> TableContext -> TableCoordinate -> Rectangle -> IO () +drawCell tableState table tc (TableCoordinate (Row row') (Column col')) rectangle' = + let (x',y',w',h') = fromRectangle rectangle' + in do + sortReverse' <- readIORef (sortReverse tableState) + sortLastCol' <- readIORef (sortLastCol tableState) + rowData' <- readIORef (rowData tableState) + numCols <- getCols table + numRows <- getRows table + if (row' < numRows && col' < numCols) + then case tc of + ContextColHeader -> do + flcPushClip rectangle' + flcDrawBox ThinUpBox rectangle' backgroundColor + if (col' < 9) + then do + flcSetColor blackColor + flcDrawInBox + (dirHeaders !! col') + (toRectangle ((x'+2),y',w',h')) + alignLeft + Nothing + Nothing + if (col' == sortLastCol') + then drawSortArrow rectangle' sortReverse' + else return () + else return () + flcPopClip + ContextCell -> do + flcPushClip rectangle' + bgColor <- do + isSelected' <- getRowSelected table row' + case isSelected' of + Right is' -> if is' + then getSelectionColor table + else return whiteColor + Left _ -> error $ "Row: " ++ (show row') ++ " is out of range." + flcSetColor bgColor + flcRectf rectangle' + flcSetFont rowFontFace rowFontSize + flcSetColor blackColor + let currentRow = rowData' !! row' + flcDrawInBox + (indexOr "" col' currentRow) + (toRectangle $ (x'+2,y',w',h')) + alignLeft + Nothing + Nothing + flcSetColor light2Color + flcRect rectangle' + flcPopClip + _ -> return () + else return () +setIndex :: Int -> [a] -> (a -> a) -> [a] +setIndex idx' xs f = + map + ( + \(i,e) -> if (i == idx') + then f e + else e + ) + (zip [0..] xs) + +indexOr :: a -> Int -> [a] -> a +indexOr fallback idx xs = + if (idx < length xs) + then xs !! idx + else fallback + +eventCallback :: TableState -> Ref TableRow -> IO () +eventCallback tableState table = do + (Column col') <- callbackCol table + context' <- callbackContext table + case context' of + ContextColHeader -> do + event' <- FL.event + mouseButton' <- FL.eventButton + if (event' == Release && mouseButton' == Mouse_Left) + then do + sortLastCol' <- readIORef (sortLastCol tableState) + if (sortLastCol' == col') + then readIORef (sortReverse tableState) >>= writeIORef (sortReverse tableState) . toggle + else writeIORef (sortReverse tableState) False + sortReverse' <- readIORef (sortReverse tableState) + rowData' <- readIORef (rowData tableState) >>= return . zip [(0 :: Int)..] + let sorted = sortBy (compare `on` (indexOr "" col'. snd)) rowData' + writeIORef + (rowData tableState) + (if sortReverse' + then (reverse $ map snd sorted) + else map snd sorted) + writeIORef (sortLastCol tableState) col' + redraw table + else return () + _ -> return () + where toggle True = False + toggle False = True + +autowidth :: Ref TableRow -> Int -> [[String]] -> IO () +autowidth table pad rowData' = do + flcSetFont headerFontFace headerFontSize + mapM_ + (\(colNum, colName) -> do + (Size (Width w') _) <- flcMeasure colName True True + setColWidth table (Column colNum) (w' + pad) + ) + (zip [0 ..] dirHeaders) + flcSetFont rowFontFace rowFontSize + mapM_ + (\row' -> do + mapM_ + (\(colIdx,col) -> do + (Size (Width wc') _) <- flcMeasure col True True + colWidth' <- getColWidth table (Column colIdx) + if (wc' + pad > colWidth') + then setColWidth table (Column colIdx) (wc' + pad) + else return () + ) + (zip [0..] row') + ) + rowData' + -- need to do { table_resized(); redraw(); } + -- but table_resized() is unexposed. + -- setting the row_header flag induces this. + getRowHeader table >>= setRowHeader table + +resize_window :: Ref DoubleWindow -> Ref TableRow -> IO () +resize_window window table = do + let width = (4 :: Int) + numCols <- getCols table + colWidthTotal <- liftM sum $ mapM (getColWidth table . Column) [0..(numCols - 1)] + let totalWidth = width + colWidthTotal + (margin * 2) + appWidth <- FL.w + if (totalWidth < 200 || totalWidth > appWidth) + then return () + else do + x' <- getX window + y' <- getY window + h' <- getH window + resize window $ toRectangle (x',y',totalWidth,h') + +main :: IO () +main = do + window <- doubleWindowNew + (Size (Width 900) (Height 500)) + Nothing + (Just "Table Sorting") + windowW <- getW window + windowH <- getH window + rows <- uncurry readProcess dirCommand "" >>= return . map words . lines + rowData' <- newIORef rows + sortReverse' <- newIORef False + sortLastCol' <- newIORef (-1) + let tableState = TableState sortReverse' sortLastCol' rowData' + begin window + table <- tableRowNew + (Rectangle + (Position (X margin) (Y margin)) + (Size (Width $ windowW - margin * 2) + (Height $ windowH - margin * 2))) + Nothing + Nothing + (drawCell tableState) + defaultCustomWidgetFuncs + defaultCustomTableFuncs + setColHeader table True + setColResize table True + setSelectionColor table yellowColor + setWhen table [WhenRelease] + readIORef rowData' >>= setRows table . length + readIORef rowData' >>= setCols table . maximum . map length + setRowHeightAll table 18 + readIORef rowData' >>= autowidth table 20 + setTooltip table "Click on column headings to toggle column sorting" + setColor table whiteColor + setCallback table (eventCallback tableState) + end window + setResizable window (Just table) + resize_window window table + _ <- showWidget window + _ <- FL.run + return () diff --git a/src/Examples/table-spreadsheet-with-keyboard-nav.hs b/src/Examples/table-spreadsheet-with-keyboard-nav.hs new file mode 100644 --- /dev/null +++ b/src/Examples/table-spreadsheet-with-keyboard-nav.hs @@ -0,0 +1,292 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Main where +import Data.IORef +import qualified Graphics.UI.FLTK.LowLevel.FL as FL +import Graphics.UI.FLTK.LowLevel.Fl_Enumerations +import Graphics.UI.FLTK.LowLevel.Fl_Types +import Graphics.UI.FLTK.LowLevel.FLTKHS + +maxCols, maxRows :: Int +maxCols = 26 +maxRows = 500 + +data SpreadsheetProperties = + SpreadsheetProperties + { + rowEdit :: Int + , colEdit :: Int + , sLeftTop :: TableCoordinate + , sRightBottom :: TableCoordinate + , values :: [[Int]] + } + +setIndex :: Int -> (a -> a) -> [a] -> [a] +setIndex idx' f xs = + map + ( + \(i,e) -> if (i == idx') + then f e + else e + ) + (zip [0..] xs) + +setValueHide :: IORef SpreadsheetProperties -> Ref Table -> Ref IntInput -> IO () +setValueHide sp' table' intInput' = do + props' <- readIORef sp' + inputValue' <- getValue intInput' >>= return . read + let updatedValues' = setIndex + (rowEdit props') + (setIndex + (colEdit props') + (const inputValue')) + (values props') + updatedProperties' = props' { + values = updatedValues' + } + writeIORef sp' updatedProperties' + hide intInput' + window' <- getWindow table' + maybe (return ()) (\w' -> setCursor w' CursorDefault ) window' + +startEditing :: IORef SpreadsheetProperties -> Ref IntInput -> Ref Table -> Int -> Int -> IO () +startEditing props' intInput' table' row' col' = do + modifyIORef props' (\p' -> p' {rowEdit = row', colEdit = col'}) + _p <- readIORef props' + setSelection table' (rowEdit _p) (colEdit _p) (rowEdit _p) (colEdit _p) + rectangle' <- findCell table' ContextCell (TableCoordinate (Row (rowEdit _p)) (Column (colEdit _p))) + case rectangle' of + Just rect' -> do + resize intInput' rect' + let cellContents = (values _p) !! (rowEdit _p) !! (colEdit _p) + _ <- setValue intInput' (show cellContents) Nothing + _ <- setPosition intInput' 0 (Just (length $ show cellContents)) + showWidget intInput' + _ <- takeFocus intInput' + return () + _ -> return () + +doneEditing :: IORef SpreadsheetProperties -> Ref IntInput -> Ref Table -> IO () +doneEditing props' intInput' table' = do + _p <- readIORef props' + visible' <- getVisible intInput' + if visible' + then setValueHide props' table' intInput' + else return () + +eventCallback :: IORef SpreadsheetProperties -> Ref IntInput -> Ref Table -> IO () +eventCallback props' intInput' table' = do + _p <- readIORef props' + (Row r') <- callbackRow table' + (Column c') <- callbackCol table' + context' <- callbackContext table' + numRows' <- getRows table' + numCols' <- getCols table' + case context' of + ContextCell -> do + event' <- FL.event + case event' of + Push -> do + doneEditing props' intInput' table' + if (r' /= (numRows' -1) && c' /= (numCols' -1)) + then startEditing props' intInput' table' r' c' + else return () + return () + Keydown -> do + eventKey' <- FL.eventKey + if (eventKey' == (SpecialKeyType Kb_Escape)) + then return () + else if (r' == numRows' - 1 || c' == numCols' -1) + then return () + else do + doneEditing props' intInput' table' + setSelection table' r' c' r' c' + startEditing props' intInput' table' r' c' + newEvent <- FL.event + if (newEvent == Keydown) + then handle intInput' newEvent >> return () + else return () + return () + _ -> return () + _c -> if (any (== _c) [ContextTable, ContextRowHeader, ContextColHeader]) + then doneEditing props' intInput' table' + else return () + +setBySlider :: Ref ValueSlider -> Ref Table -> (Ref Table -> Int -> IO ()) -> IO () +setBySlider slider' table' f = do + v' <- getValue slider' + f table' (truncate $ v'+1) + redraw table' + +setColsCb :: Ref Table -> Ref ValueSlider -> IO () +setColsCb table' slider' = setBySlider slider' table' setCols + +setRowsCb :: Ref Table -> Ref ValueSlider -> IO () +setRowsCb table' slider' = setBySlider slider' table' setRows + +drawCell :: IORef SpreadsheetProperties -> Ref IntInput -> Ref Table -> TableContext -> TableCoordinate -> Rectangle -> IO () +drawCell props' intInput' table' context' (TableCoordinate (Row row') (Column col')) rectangle' = do + _p <- readIORef props' + numRows' <- getRows table' + numCols' <- getCols table' + case context' of + ContextStartPage -> do + (p1,p2) <- getSelection table' + modifyIORef props' (\p -> p {sLeftTop = p1, sRightBottom = p2}) + ContextColHeader -> do + flcSetFont helveticaBold (FontSize 14) + flcPushClip rectangle' + getColHeaderColor table' >>= flcDrawBox ThinUpBox rectangle' + flcSetColor blackColor + if (col' == numCols' - 1) + then flcDrawInBox "TOTAL" rectangle' alignCenter Nothing Nothing + else flcDrawInBox [toEnum $ fromEnum 'A' + col'] rectangle' alignCenter Nothing Nothing + flcPopClip + ContextRowHeader -> do + flcSetFont helveticaBold (FontSize 14) + flcPushClip rectangle' + getRowHeaderColor table' >>= flcDrawBox ThinUpBox rectangle' + flcSetColor blackColor + if (row' == numRows' - 1) + then flcDrawInBox "TOTAL" rectangle' alignCenter Nothing Nothing + else flcDrawInBox (show $ row' + 1) rectangle' alignCenter Nothing Nothing + flcPopClip + ContextCell-> do + visible' <- getVisible intInput' + let (TableCoordinate (Row sTop') (Column sLeft')) = sLeftTop _p + (TableCoordinate (Row sBottom') (Column sRight')) = sRightBottom _p + if (row' == (rowEdit _p) && col' == (colEdit _p) && visible') + then return () + else do + if (row' >= sTop' && row' <= sBottom' && col' >= sLeft' && col' <= sRight') + then flcDrawBox ThinUpBox rectangle' yellowColor + else if (col' < numCols' - 1 && row' < numRows' - 1) + then do + selected' <- isSelected table' (TableCoordinate (Row row') (Column col')) + flcDrawBox ThinUpBox rectangle' (if selected' then yellowColor else whiteColor) + else flcDrawBox ThinUpBox rectangle' (Color 0xbbddbb00) + flcPushClip rectangle' + flcSetColor blackColor + if (col' == numCols' - 1 || row' == numRows' - 1) + then do + flcSetFont helveticaBold (FontSize 14) + let shownValues = map (take (numCols'- 1)) $ take (numRows' -1) (values _p) + let s' = if (col' == numCols' - 1 && row' == numRows' - 1) + then (show . sum . map sum) shownValues + else if (col' == numCols' - 1) + then (show $ sum $ shownValues !! row') + else if (row' == numRows' - 1) + then (show . sum . map (\r -> r !! col')) shownValues + else "" + let (x',y',w',h') = fromRectangle rectangle' + flcDrawInBox s' (toRectangle (x'+3,y'+3,w'-6,h'-6)) alignRight Nothing Nothing + else do + flcSetFont helvetica (FontSize 14) + let s' = show $ (values _p) !! row' !! col' + let (x',y',w',h') = fromRectangle rectangle' + flcDrawInBox s' (toRectangle (x'+3,y'+3,w'-6,h'-6)) alignRight Nothing Nothing + flcPopClip + ContextRCResize -> do + visible' <- getVisible intInput' + if (not visible') + then return () + else do + cellRectangle' <- findCell table' ContextTable (TableCoordinate (Row row') (Column col')) + case cellRectangle' of + Just cr' -> if (cr' == rectangle') + then return () + else resize intInput' cr' + Nothing -> return () + _ -> return () + +main :: IO () +main = do + FL.setOption FL.OptionArrowFocus True + win' <- doubleWindowNew + (Size (Width 922) (Height 382)) + Nothing + (Just "Fl_Table Spreadsheet with Keyboard Navigation") + winWidth' <- getW win' + winHeight' <- getH win' + let values' = + map + (\r' -> + map + (\c' -> (r'+2) * (c'+3)) + [0 .. (maxCols -1)] + ) + [0.. (maxRows - 1)] + props' <- newIORef $ + SpreadsheetProperties + 0 + 0 + (TableCoordinate (Row 0) (Column 0)) + (TableCoordinate (Row 0) (Column 0)) + values' + let tableWidth' = winWidth' - 80 + tableHeight' = winHeight' - 80 + intInput' <- intInputNew + (toRectangle + ( + (truncate $ ((fromIntegral tableWidth' / 2) :: Double)), + (truncate $ ((fromIntegral tableHeight' / 2) :: Double)), + 0, + 0 + ) + ) + Nothing + hide intInput' + setWhen intInput' [WhenEnterKeyAlways] + setMaximumSize intInput' 5 + + spreadsheet' <- tableCustom + (toRectangle (20,20,tableWidth', tableHeight')) + Nothing + Nothing + (drawCell props' intInput') + defaultCustomWidgetFuncs + defaultCustomTableFuncs + whens' <- getWhen spreadsheet' + setWhen spreadsheet' $ [WhenNotChanged] ++ whens' + setSelection spreadsheet' 0 0 0 0 + setCallback intInput' (setValueHide props' spreadsheet') + setCallback spreadsheet' (eventCallback props' intInput') + setTooltip spreadsheet' "Use keyboard to navigate cells:\n Arrow keys or Tab/Shift-Tab" + -- Table rows + setRowHeader spreadsheet' True + setRowHeaderWidth spreadsheet' 70 + setRowResize spreadsheet' True + setRows spreadsheet' 11 + setRowHeightAll spreadsheet' 25 + -- Table cols + setColHeader spreadsheet' True + setColHeaderHeight spreadsheet' 25 + setColResize spreadsheet' True + setCols spreadsheet' 11 + setColWidthAll spreadsheet' 70 + + begin win' + -- Rows slider + setRows' <- valueSliderNew (toRectangle (winWidth'-40,20,20,winHeight'-80)) Nothing + setType setRows' VertNiceSliderType + bounds setRows' 2 (fromIntegral maxRows) + setStep setRows' 1 + numRows' <- getRows spreadsheet' + _ <- setValue setRows' (fromIntegral $ numRows'-1) + setCallback setRows' (setRowsCb spreadsheet') + setWhen setRows' [WhenChanged] + clearVisibleFocus setRows' + -- Cols slider + setCols' <- valueSliderNew (toRectangle (20,winHeight'-40,winWidth'-80,20)) Nothing + setType setCols' HorNiceSliderType + bounds setCols' 2 (fromIntegral maxCols) + setStep setCols' 1 + numCols' <- getCols spreadsheet' + _ <- setValue setCols' (fromIntegral $ numCols'-1) + setCallback setCols' (setColsCb spreadsheet') + setWhen setCols' [WhenChanged] + clearVisibleFocus setCols' + end win' + setResizable win' (Just spreadsheet') + showWidget win' + _ <- FL.run + return () diff --git a/src/Examples/textdisplay-with-colors.hs b/src/Examples/textdisplay-with-colors.hs new file mode 100644 --- /dev/null +++ b/src/Examples/textdisplay-with-colors.hs @@ -0,0 +1,23 @@ +module Main where +import qualified Graphics.UI.FLTK.LowLevel.FL as FL +import Graphics.UI.FLTK.LowLevel.Fl_Types +import Graphics.UI.FLTK.LowLevel.Fl_Enumerations +import Graphics.UI.FLTK.LowLevel.FLTKHS +main :: IO () +main = do + let stes = [(StyleTableEntry (Just redColor) (Just courier) (Just $ FontSize 18)), + (StyleTableEntry (Just darkYellowColor) (Just courier) (Just $ FontSize 18)), + (StyleTableEntry (Just darkGreenColor) (Just courier) (Just $ FontSize 18)), + (StyleTableEntry (Just blueColor) (Just courier) (Just $ FontSize 18))] + win <- windowNew (toSize (640,480)) Nothing (Just $ "Simple Text Display With Colors") + disp <- textDisplayNew (toRectangle (20,20,640-40,480-40)) Nothing + tbuff <- textBufferNew Nothing Nothing + sbuff <- textBufferNew Nothing Nothing + setBuffer disp (Just tbuff) + highlightData disp sbuff (indexStyleTableEntries stes) Nothing + setText tbuff "Red Line 1\nYel Line 2\nGrn Line 3\nBlu Line 4\nRed Line 5\nYel Line 6\nGrn Line 7\nBlu Line 8\n" + setText sbuff "AAAAAAAAAA\nBBBBBBBBBB\nCCCCCCCCCC\nDDDDDDDDDD\nAAAAAAAAAA\nBBBBBBBBBB\nCCCCCCCCCC\nDDDDDDDDDD\n" + setResizable win (Just disp) + showWidget win + _ <- FL.run + return () diff --git a/src/Examples/texteditor-simple.hs b/src/Examples/texteditor-simple.hs new file mode 100644 --- /dev/null +++ b/src/Examples/texteditor-simple.hs @@ -0,0 +1,15 @@ +module Main where +import qualified Graphics.UI.FLTK.LowLevel.FL as FL +import Graphics.UI.FLTK.LowLevel.Fl_Types +import Graphics.UI.FLTK.LowLevel.FLTKHS + +main :: IO () +main = do + win <- doubleWindowNew (toSize (640,480)) Nothing (Just "Simple Fl_Text_Editor") + buff <- textBufferNew Nothing Nothing + edit <- textEditorNew (toRectangle (20,20,(640-40),(480-40))) Nothing + setBuffer edit (Just buff) + showWidget win + setText buff "line 0\nline 1\nline 2\nline 3\nline 4\nline 5\nline 6\nline 7\nline 8\nline 9\nline 10\nline 11\nline 12\nline 13\nline 14\nline 15\nline 16\nline 17\nline 18\nline 19\nline 20\nline 21\nline 22\nline 23\n" + _ <- FL.run + return () diff --git a/src/Examples/threads.hs b/src/Examples/threads.hs new file mode 100644 --- /dev/null +++ b/src/Examples/threads.hs @@ -0,0 +1,87 @@ +-- This example shows how to run a CPU-intensive thread in the +-- background while keeping the UI responsive. All FLTK calls are +-- done on the main thread. +-- +-- Press the "start background thread" button to start the +-- CPU-intensive thread. Then observe that clicking the "increment" +-- button remains responsive. + +module Main where + +import qualified Graphics.UI.FLTK.LowLevel.FL as FL +import Graphics.UI.FLTK.LowLevel.Fl_Types +import Graphics.UI.FLTK.LowLevel.FLTKHS + +import Control.Concurrent +import Control.Concurrent.STM +import Control.Exception (evaluate) +import Control.Monad +import Data.IORef + +main :: IO () +main = do + -- Set up the window and widgets. + w <- windowNew (Size (Width 260) (Height 110)) Nothing Nothing + startButton <- buttonNew (Rectangle (Position (X 15) (Y 10)) (Size (Width 230) (Height 25))) (Just "start background thread") + b <- outputNew (Rectangle (Position (X 135) (Y 40)) (Size (Width 110) (Height 25))) (Just "primes ") (Just FlNormalOutput) + button <- buttonNew (Rectangle (Position (X 15) (Y 75)) (Size (Width 110) (Height 25))) (Just "increment") + counter <- outputNew (Rectangle (Position (X 135) (Y 75)) (Size (Width 110) (Height 25))) Nothing (Just FlNormalOutput) + clearVisibleFocus b + clearVisibleFocus counter + + -- The communication channel between the CPU-heavy thread and the + -- main thread. + c <- newTChanIO + + -- When the start button is pressed, start the CPU-heavy thread. + setCallback startButton $ \_ -> do + void $ forkIO $ computationThread c + + -- Start the click counter at zero. + counterRef <- newIORef (0 :: Integer) + _ <- setValue counter (show (0 :: Integer)) Nothing + + -- When the button is pressed, increment the counter and update the + -- label. + setCallback button $ \_ -> do + modifyIORef counterRef (+1) + x <- readIORef counterRef + void $ setValue counter (show x) Nothing + + -- Every so often, check for messages from our worker thread. + FL.addTimeout 0.025 (tick b c) + + -- Start the UI. + showWidget w + _ <- FL.run + return () + +-- Check for a message from our worker thread. If there is a message, +-- gobble all the messages up and set the label to the contents on the +-- most recent message. +tick :: Ref Output -> TChan Integer -> IO () +tick b c = do + mx <- atomically $ tryReadTChan c + case mx of + Nothing -> return () + Just x -> inner x + FL.repeatTimeout 0.025 (tick b c) + where inner x = do + mx <- atomically $ tryReadTChan c + case mx of + Nothing -> void $ setValue b (show x) Nothing + Just x' -> inner x' + + +-- Very slow prime-testing predicate. +isPrime :: Integer -> Bool +isPrime 1 = False +isPrime x = not $ any (\y -> x `mod` y == 0) [2..x-1] + +-- Write prime numbers to a channel forever. +computationThread :: TChan Integer -> IO () +computationThread channel = do + let primes = filter isPrime [1000000..] + forM_ primes $ \p -> do + _ <- evaluate p + atomically $ writeTChan channel p diff --git a/src/Examples/tile.hs b/src/Examples/tile.hs new file mode 100644 --- /dev/null +++ b/src/Examples/tile.hs @@ -0,0 +1,69 @@ +module Main where +import qualified Graphics.UI.FLTK.LowLevel.FL as FL +import Graphics.UI.FLTK.LowLevel.FLTKHS +import Graphics.UI.FLTK.LowLevel.Fl_Enumerations + +main :: IO () +main = do + window <- doubleWindowNew (Size (Width 300) (Height 300)) Nothing Nothing + setBox window NoBox + _ <- setResizable window (Just window) + tile <- tileNew (toRectangle (0,0,300,300)) Nothing + box0 <- boxNew (toRectangle (0,0,150,150)) (Just "0") + setBox box0 DownBox + setColor box0 (Color 9) + setLabelsize box0 (FontSize 36) + setAlign box0 (Alignments [AlignTypeClip]) + + w1 <- doubleWindowNew (Size (Width 150) (Height 150)) (Just (Position (X 150) (Y 0))) Nothing + begin w1 + setBox w1 NoBox + box1 <- boxNew (toRectangle (0,0,150,150)) (Just "1\nThis is a child window") + setBox box1 DownBox + setColor box1 (Color 19) + setLabelsize box1 (FontSize 18) + setAlign box1 (Alignments [AlignTypeClip, AlignTypeInside, AlignTypeWrap]) + _ <- setResizable w1 (Just box1) + end w1 + + box2a <- boxNew (toRectangle (0,150,70,150)) (Just "2a") + setBox box2a DownBox + setColor box2a (Color 12) + setLabelsize box2a (FontSize 36) + setAlign box2a (Alignments [AlignTypeClip]) + + box2b <- boxNew (toRectangle (70,150,80,150)) (Just "2b") + setBox box2b DownBox + setColor box2b (Color 13) + setLabelsize box2b (FontSize 36) + setAlign box2b (Alignments [AlignTypeClip]) + + box3a <- boxNew (toRectangle (150,150,150,70)) (Just "3a") + setBox box3a DownBox + setColor box3a (Color 12) + setLabelsize box3a (FontSize 36) + setAlign box3a (Alignments [AlignTypeClip]) + + box3b <- boxNew (toRectangle (150,(150+70),150,80)) (Just "3b") + setBox box3b DownBox + setColor box3b (Color 13) + setLabelsize box3b (FontSize 36) + setAlign box3b (Alignments [AlignTypeClip]) + + -- create the symmetrical resize box with dx and dy pixels distance, resp. + -- from the borders of the Fl_Tile widget + let dx = 20 + let dy = 20 + tileX <- getX tile + tileY <- getY tile + tileW <- getW tile + tileH <- getH tile + r <- boxNew (toRectangle ((tileX+dx), (tileY+dy), (tileW-(2*dx)), (tileH-(2*dy)))) Nothing + _ <- setResizable tile (Just r) + end tile + end window + + _ <- showWidget w1 + _ <- showWidget window + _ <- FL.run + return () diff --git a/src/Examples/tree-simple.hs b/src/Examples/tree-simple.hs new file mode 100644 --- /dev/null +++ b/src/Examples/tree-simple.hs @@ -0,0 +1,48 @@ +module Main where +import qualified Graphics.UI.FLTK.LowLevel.FL as FL +import Graphics.UI.FLTK.LowLevel.Fl_Types +import Graphics.UI.FLTK.LowLevel.FLTKHS + +treeCallback :: Ref Tree -> IO () +treeCallback tree' = do + (Just item') <- getCallbackItem tree' + reason' <- getCallbackReason tree' + label' <- getLabel item' + case reason' of + TreeReasonSelected -> do + (Just path') <- itemPathname tree' item' + print $ "TreeCallback: Item selected =" ++ label' ++ "Full pathname=" ++ path' ++ "\n" + TreeReasonDeselected -> + print $ "TreeCallback: Item deselected =" ++ label' ++ "\n" + TreeReasonOpened -> + print $ "TreeCallback: Item opened =" ++ label' ++ "\n" + TreeReasonClosed -> + print $ "TreeCallback: Item closed =" ++ label' ++ "\n" + _ -> print "" +main :: IO () +main = do + _ <- FL.setScheme "gtk+" + window <- windowNew (toSize (250,400)) Nothing (Just "Simple Tree") + begin window + windowWidth' <- getW window + windowHeight' <- getH window + tree <- treeNew (toRectangle (10,10,windowWidth' - 20,windowHeight' - 20)) Nothing + setShowroot tree False + _ <- add tree "Flintstones/Fred" + _ <- add tree "Flintstones/Wilma" + _ <- add tree "Flintstones/Pebbles" + _ <- add tree "Simpsons/Homer" + _ <- add tree "Simpsons/Marge" + _ <- add tree "Simpsons/Bart" + _ <- add tree "Simpsons/Lisa" + _ <- add tree "Pathnames/\\/bin" + _ <- add tree "Pathnames/\\/usr\\/sbin" + _ <- add tree "Pathnames/C:\\\\Program Files" + _ <- add tree "Pathnames/C:\\\\Documents and Settings" + close tree (TreeItemNameLocator (TreeItemName "Simpsons")) + close tree (TreeItemNameLocator (TreeItemName "Pathnames")) + setCallback tree treeCallback + end window + showWidget window + _ <- FL.run + return ()