fltkhs 0.5.4.3 → 0.5.4.4
raw patch · 13 files changed
+609/−26 lines, 13 filesdep +OpenGLRawdep ~textsetup-changednew-component:exe:fltkhs-example-openglPVP: minor bump suggested
API additions: PVP suggests at least a minor version bump
Dependencies added: OpenGLRaw
Dependency ranges changed: text
API changes (from Hackage documentation)
+ Graphics.UI.FLTK.LowLevel.FL: awake :: IO ()
+ Graphics.UI.FLTK.LowLevel.FL: awakeToHandler :: IO ()
+ Graphics.UI.FLTK.LowLevel.FL: lock :: IO Bool
+ Graphics.UI.FLTK.LowLevel.FL: unlock :: IO ()
Files
- .gitignore +1/−0
- CONTRIBUTING.md +36/−0
- Setup.hs +27/−3
- c-src/Fl_C.cpp +4/−0
- c-src/Fl_C.h +1/−0
- default.nix +78/−0
- fltkhs.cabal +110/−13
- shell.nix +66/−0
- src/Graphics/UI/FLTK/LowLevel/FL.chs +16/−0
- src/Graphics/UI/FLTK/LowLevel/PNGImage.chs +3/−3
- src/Graphics/UI/FLTK/LowLevel/RGBImage.chs +7/−7
- src/TestPrograms/Buttons.hs +10/−0
- src/TestPrograms/OpenGL.hs +250/−0
.gitignore view
@@ -1,3 +1,4 @@+result *.a *.o .\#*
+ CONTRIBUTING.md view
@@ -0,0 +1,36 @@+# CONTRIBUTING++(this file is a work-in-progress)++if you know `Nix`, any help would be great.++## Nix ++Currently, the nix file (`default.nix`) is non-standard, +i.e. not automatically generated from `cabal2nix`. Ideally, +all information can be specified from the `.cabal`, with an+optional `.nix` wrapper to passthrough the configuration arguments +(`bundled` and `opengl`). ++FWIW, it's been tested on:++* the latest `nixpkgs-unstable` (Jan 2018),+* Ubuntu LTS 14.04+* `GHC` 8.2.2 +* `cabal-install` (i.e. `Cabal`) 2.0.0.1++On Linux, `fltk` uses `mesa` (for OpenGL only) and `libjpeg` (for JPEG). +The build script calls `fltk-config` and `autoconf`. ++It's been successfully tested with the default flags:++ nix-build shell.nix + fltkhs-buttons++and with the `-fopengl` flag:++ nix-shell shell.nix --arg opengl true+ cabal configure -fopengl+ cabal build+ cabal run fltkhs-example-opengl+
Setup.hs view
@@ -21,6 +21,7 @@ import Distribution.Simple.Program.Db import Distribution.Simple.PreProcess import Distribution.Simple.Register ( generateRegistrationInfo, registerPackage )+import qualified Distribution.Simple.Register as Register import Distribution.Simple.InstallDirs (fromPathTemplate) import System.IO.Unsafe (unsafePerformIO) import System.IO.Error@@ -38,6 +39,29 @@ import Distribution.InstalledPackageInfo (ldOptions, extraGHCiLibraries, showInstalledPackageInfo, libraryDynDirs, libraryDirs) import System.Environment (getEnv, setEnv) +----------------------------------------+-- compatibility between Cabal 1 and Cabal 2++-- "If you have a custom-setup stanza, you should be able to use the MIN_VERSION_Cabal macro in your setup script."++-- cabal >=2.0.0.2+#if defined(MIN_VERSION_Cabal) && MIN_VERSION_Cabal(2,0,0)+_FlagName = mkFlagName +#else+_FlagName = FlagName +#endif++-- cabal >=2.0.1.1+#if defined(MIN_VERSION_Cabal) && MIN_VERSION_Cabal(2,0,1)+_registerPackage verbosity lbi packageDbs installedPkgInfo + = registerPackage verbosity (compiler lbi) (withPrograms lbi) packageDbs installedPkgInfo Register.defaultRegisterOptions +#else+_registerPackage verbosity lbi packageDbs installedPkgInfo+ = registerPackage verbosity (compiler lbi) (withPrograms lbi) False {- multiinstance -} packageDbs installedPkgInfo+#endif++----------------------------------------+ main :: IO () main = defaultMainWithHooks autoconfUserHooks { preConf = myPreConf,@@ -192,8 +216,8 @@ else Just ([head str], tail str)) haystack) -bundledBuild flags = flagIsSet (FlagName "bundled") flags-openGLSupport flags = flagIsSet (FlagName "opengl") flags+bundledBuild flags = flagIsSet (_FlagName "bundled") flags+openGLSupport flags = flagIsSet (_FlagName "opengl") flags bundlePrefix flags dir = let (Distribution.Simple.Setup.Flag prefixTemplate) = libdir (configInstallDirs flags)@@ -385,7 +409,7 @@ _ | modeGenerateRegFile -> writeRegistrationFile installedPkgInfo | modeGenerateRegScript -> die "Generate Reg Script not supported" | otherwise ->- registerPackage verbosity (compiler lbi) (withPrograms lbi) False {- multiinstance -} packageDbs installedPkgInfo+ _registerPackage verbosity lbi packageDbs installedPkgInfo where modeGenerateRegFile = isJust (flagToMaybe (regGenPkgConf regFlags)) regFile = fromMaybe (display (packageId pkg) <.> "conf")
c-src/Fl_C.cpp view
@@ -569,6 +569,10 @@ FL_EXPORT_C(void,Fl_awake)(){ Fl::awake((void*)0); }+ FL_EXPORT_C(void,Fl_awake_to_handler)() {+ char* c = strdup(" ");+ Fl::awake((void*)c);+ } FL_EXPORT_C(void,Fl_awake_with_message)(void* message){ Fl::awake(message); }
c-src/Fl_C.h view
@@ -249,6 +249,7 @@ FL_EXPORT_C_HEADER(int ,Fl_lock,()); FL_EXPORT_C_HEADER(void ,Fl_unlock,()); FL_EXPORT_C_HEADER(void ,Fl_awake,());+ FL_EXPORT_C_HEADER(void ,Fl_awake_to_handler,()); FL_EXPORT_C_HEADER(void ,Fl_awake_with_message,(void* message)); FL_EXPORT_C_HEADER(int ,Fl_awake_with_cb,(fl_Awake_Handler cb)); FL_EXPORT_C_HEADER(int ,Fl_awake_with_cb_message,(fl_Awake_Handler cb, void* message));
+ default.nix view
@@ -0,0 +1,78 @@+{ mkDerivation, stdenv++, autoconf, c2hs++, fltk, libjpeg, mesa++, base, bytestring, Cabal, directory, filepath, mtl, OpenGLRaw, parsec, text++, cabalFlags ? {}++}:++/*+This file is written manually, not generated automatically, because+cabal2nix doesn't provision correctly for this package's complex custom setup.+*/++let ++ # "import" utilities+ inherit (stdenv.lib) mapAttrs attrValues concatStringsSep optionals;++ flags + = { bundled = false; demos = true; opengl = false; } # same names/defaults as the cabal flags+ // cabalFlags; # override defaults with any extra flags+ # NOTE `bundled` is currently ignored.++ nixSet2cabalInstallOptions = inputFlags:+ let outputFlags = + (attrValues # e.g. [ "-f-bundled" "-fdemos" "-f-opengl" ]+ (mapAttrs (k: v: (if v then "-f" else "-f-") + k) # e.g. { bundled = "-f-bundled"; demos = "-fdemos"; opengl = "-f-opengl"; }+ inputFlags)); # e.g. { bundled = false; demos = true; opengl = false; }+ + in outputFlags;++in++mkDerivation {+ pname = "fltkhs";+ version = "0.5.4.3";++ homepage = "http://github.com/deech/fltkhs";+ description = "FLTK bindings";+ license = stdenv.lib.licenses.mit;++ src = ./.;+ isLibrary = true;+ isExecutable = true;++ # including .cabal `flag`s+ configureFlags = nixSet2cabalInstallOptions flags;++ # `custom-setup`+ setupHaskellDepends = [ autoconf base c2hs Cabal directory filepath ];+ # ^ `setup-depends`++ # `library`+ libraryToolDepends = [ autoconf c2hs fltk ];+ # ^ `build-tools:` + # fltk provides fltk-config + libraryHaskellDepends = [ base bytestring text ];+ # ^ `build-depends:` + librarySystemDepends = [ + fltk libjpeg + ] ++ optionals flags.opengl [ + mesa + ];+ # ^ `extra-libraries:` ++ # all the `executable`s+ executableHaskellDepends = [+ base directory filepath mtl parsec text+ ] ++ optionals flags.opengl [+ OpenGLRaw + ];+ # ^ `build-depends:` ++}
fltkhs.cabal view
@@ -1,5 +1,5 @@ name : fltkhs-version : 0.5.4.3+version : 0.5.4.4 synopsis : FLTK bindings description: Low level bindings for the FLTK GUI toolkit. For installation and quick start instruction please scroll all the way down to the README. license : MIT@@ -11,30 +11,68 @@ bug-reports: https://github.com/deech/fltkhs/issues copyright: © 2017 Aditya Siram All Rights Reserved category: UI,Graphics,GUI,User Interfaces++----------------------------------------+ build-type: Custom cabal-version: >=1.24+ -- for custom-setup+ source-repository head type: git location: http://github.com/deech/fltkhs -Flag Bundled+----------------------------------------+-- by default,+--+-- * no OpenGL support+-- * the system `fltk` package is used (not the bundled tarball)+--++Flag bundled Description: Use the bundled FLTK library.- Manual: True+ Manual: True Default: False -Flag Opengl+Flag demos+ Description: Build the demo apps (`fltkhs-buttons` and `fltkhs-example-opengl`).+ Manual: True+ Default: True++Flag opengl Description: Enable OpenGL support.- Manual : True+ Manual: True Default: False +----------------------------------------+ custom-setup setup-depends:- base >= 4.5 && < 4.11,- Cabal >= 1.24.1 && < 1.25,+ Cabal >= 1.24.1 && < 3, filepath,- directory >= 1.2.3.0+ directory >= 1.2.3.0,+ -- c2hs >=0.28,+ base >= 4.5 && < 4.11 +----------------------------------------+ library++ build-tools: c2hs+ --+ -- extra-libraries: jpeg+ -- -- from the `libjpeg` system package+ --+ -- if !flag(bundled)+ -- -- when `bundled`, we don't need a system `fltk`, since we build it ourself+ -- extra-libraries: fltk+ -- build-tools: fltk-config+ -- -- the `fltk` system package provides the `fltk-config` executable+ --+ -- if flag(opengl)+ -- extra-libraries: GL, GLU+ -- -- e.g. from the `mesa` and `freeglut` system packages (respectively)+ if flag(opengl) exposed-modules: Graphics.UI.FLTK.LowLevel.Gl@@ -132,17 +170,21 @@ Graphics.UI.FLTK.LowLevel.PNGImage Graphics.UI.FLTK.LowLevel.PNMImage Graphics.UI.FLTK.LowLevel.X++ other-modules: C2HS+ build-depends: base == 4.*, bytestring, text >= 0.2 && < 1.3- build-tools: c2hs+ hs-source-dirs: src- other-modules: C2HS- include-dirs: ./c-src, ./+ include-dirs: ./c-src, ./+ default-extensions: GADTs default-language: Haskell2010 ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-orphans -fno-warn-unused-matches -fno-warn-dodgy-exports+ if impl(ghc >= 8.0.1) cpp-options: -DHASCALLSTACK_AVAILABLE cpp-options: -DCUSTOM_TYPE_ERRORS@@ -151,18 +193,24 @@ cpp-options: -DCALLSTACK_AVAILABLE if impl(ghc >= 7.10) cpp-options: -DOVERLAPPING_INSTANCES_DEPRECATED+ if os(darwin) cc-options: -U__BLOCKS__ -D_Nonnull= +----------------------------------------+ Executable fltkhs-fluidtohs- Main-Is: Main.hs++ Main-Is: Main.hs Hs-Source-Dirs: src/Fluid+ Other-modules: Generate Lookup Parser Types Utils+ Build-Depends: base == 4.*, filepath,@@ -170,8 +218,10 @@ parsec >= 3.1.6, directory >= 1.2.1.0, mtl+ default-language: Haskell2010 ghc-Options: -Wall -threaded+ if os(windows) && arch(x86_64) cpp-options: -DWIN64 if os(windows)@@ -182,18 +232,65 @@ if !os(darwin) && !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" +----------------------------------------+-- Demos++-- simple example of different fltk button widgets Executable fltkhs-buttons- Main-Is: Buttons.hs+ if !flag(demos)+ buildable: False++ Main-Is: Buttons.hs Hs-Source-Dirs: src/TestPrograms+ Build-Depends: base == 4.*, fltkhs+ default-language: Haskell2010 ghc-Options: -Wall -threaded+ if os(windows) ghc-Options: -optl-mwindows 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(darwin) ghc-Options: "-optl-Wl,-lfltkc"+ if !os(darwin) && !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"++-- example of fltk OpenGL support+--+-- requires the `opengl` flag, e.g.:+--+-- stack build --flag fltkhs:opengl+-- cabal configure -fopengl && cabal build+--+Executable fltkhs-example-opengl+ if !(flag(demos) && flag(opengl))+ buildable: False++ Main-Is: OpenGL.hs+ Hs-Source-Dirs: src/TestPrograms++ Build-Depends:+ base == 4.*,+ fltkhs,+ text >= 1.2.2.0,+ OpenGLRaw >= 3 && < 3.3++ default-language: Haskell2010+ ghc-Options: -Wall -threaded++ if os(windows)+ ghc-Options: -optl-mwindows+ 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(darwin)+ ghc-Options: "-optl-Wl,-lfltkc"++ if !os(darwin) && !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"++----------------------------------------
+ shell.nix view
@@ -0,0 +1,66 @@+{ nixpkgsPath ? <nixpkgs> +, overlays ? []++, compiler ? "default" ++, opengl ? false+, demo ? true+}:++/* Usage:++A.+ cabal clean+ nix-build shell.nix+ fltkhs-buttons++B.+ nix-shell + cabal clean+ cabal configure + cabal build+ cabal run fltkhs-buttons++C.+ nix-shell --arg opengl 'true'+ cabal clean+ cabal configure -fopengl+ cabal build+ cabal run fltkhs-example-opengl++*/++/*+This file is written manually, not generated automatically, +to lift the package's `.cabal` flags into `.nix` flags.+*/++let++ # defaultNixpkgs = import nixpkgsPath {};++ customNixpkgs = import nixpkgsPath { inherit overlays; };+ # by default:+ # customNixpkgs = import <nixpkgs> {};++ /*+ $ echo $NIX_PATH+ nixpkgs=/home/sboo/.nix-defexpr/channels/nixpkgs+ */++ inherit (customNixpkgs) pkgs;++ flags = { cabalFlags = { inherit demo opengl; }; };+ # same names/defaults as the `.cabal` flags++ f = import ./default.nix;++ haskellPackages = if compiler == "default"+ then pkgs.haskellPackages+ else pkgs.haskell.packages.${compiler};++ drv = haskellPackages.callPackage f flags;++in++ if pkgs.lib.inNixShell then drv.env else drv
src/Graphics/UI/FLTK/LowLevel/FL.chs view
@@ -15,6 +15,10 @@ ready, option, setOption,+ lock,+ unlock,+ awake,+ awakeToHandler, addAwakeHandler_, getAwakeHandler_, display,@@ -256,6 +260,18 @@ setOption :: Option -> Bool -> IO () setOption o t = {#call Fl_set_option as fl_set_option #} (cFromEnum o) (Graphics.UI.FLTK.LowLevel.Utils.cFromBool t)++lock :: IO Bool+lock = {#call Fl_lock as fl_lock #} >>= return . cToBool++unlock :: IO ()+unlock = {#call Fl_unlock as fl_unlock #}++awake :: IO ()+awake = {#call Fl_awake as fl_awake #}++awakeToHandler :: IO ()+awakeToHandler = {#call Fl_awake_to_handler as fl_awake_to_handler #} unsafeToCallbackPrim :: GlobalCallback -> FunPtr CallbackPrim unsafeToCallbackPrim = (Unsafe.unsafePerformIO) . toGlobalCallbackPrim
src/Graphics/UI/FLTK/LowLevel/PNGImage.chs view
@@ -26,9 +26,9 @@ pngImageNew filename' = pngImageNew' filename' >>= toRef >>= checkImage pngImageNewWithData :: T.Text -> B.ByteString -> IO (Either UnknownError (Ref PNGImage))-pngImageNewWithData l' data' = do- png' <- copyByteStringToCString data'- pngImageNewWithData' l' (castPtr png') (B.length data') >>= toRef >>= checkImage+pngImageNewWithData l' data' =+ B.useAsCString data' $ \png' ->+ pngImageNewWithData' l' (castPtr png') (B.length data') >>= toRef >>= checkImage -- $hierarchy -- @
src/Graphics/UI/FLTK/LowLevel/RGBImage.chs view
@@ -30,13 +30,13 @@ {# fun Fl_RGB_Image_New_With_LD as rgbImageNew_WithLD' {id `Ptr CUChar',`Int',`Int', `Int'} -> `Ptr ()' id #}; {# fun Fl_RGB_Image_New_With_D_LD as rgbImageNew_WithD_LD' {id `Ptr CUChar',`Int',`Int', `Int', `Int'} -> `Ptr ()' id #}; rgbImageNew :: B.ByteString -> Size -> Maybe Depth -> Maybe LineSize -> IO (Ref RGBImage)-rgbImageNew bits' (Size (Width width') (Height height')) depth' linesize' = do- asCString <- copyByteStringToCString bits'- case (depth', linesize') of- (Just (Depth imageDepth) , Nothing) -> rgbImageNew_WithD' (castPtr asCString) width' height' imageDepth >>= toRef- (Nothing, Just (LineSize l')) -> rgbImageNew_WithLD' (castPtr asCString) width' height' l' >>= toRef- (Just (Depth imageDepth), Just (LineSize l')) -> rgbImageNew_WithD_LD' (castPtr asCString) width' height' imageDepth l' >>= toRef- (Nothing, Nothing) -> rgbImageNew' (castPtr asCString) width' height' >>= toRef+rgbImageNew bits' (Size (Width width') (Height height')) depth' linesize' =+ useAsCString bits' $ \asCString ->+ case (depth', linesize') of+ (Just (Depth imageDepth) , Nothing) -> rgbImageNew_WithD' (castPtr asCString) width' height' imageDepth >>= toRef+ (Nothing, Just (LineSize l')) -> rgbImageNew_WithLD' (castPtr asCString) width' height' l' >>= toRef+ (Just (Depth imageDepth), Just (LineSize l')) -> rgbImageNew_WithD_LD' (castPtr asCString) width' height' imageDepth l' >>= toRef+ (Nothing, Nothing) -> rgbImageNew' (castPtr asCString) width' height' >>= toRef -- | Check that the given RGBImage (or subclass of RGBImage) has a non-zero width. --
src/TestPrograms/Buttons.hs view
@@ -1,4 +1,14 @@ {-# LANGUAGE OverloadedStrings #-}++{- | Ported from [buttons.cxx]<https://github.com/IngwiePhoenix/FLTK/blob/master/test/buttons.cxx>,+which is also included in @fltkhs@ at @c-examples\/buttons.c@. ++@+cabal configure -fdemos+cabal run fltkhs-buttons+@++-} module Main where import Graphics.UI.FLTK.LowLevel.FL as FL
+ src/TestPrograms/OpenGL.hs view
@@ -0,0 +1,250 @@+{-# LANGUAGE OverloadedStrings, PatternSynonyms #-}++{- | Ported from [cube.cxx]<https://github.com/IngwiePhoenix/FLTK/blob/master/test/cube.cxx>.++@+cabal configure -fopengl -fdemos+cabal run fltkhs-example-opengl+@++-}+module Main where++import Graphics.UI.FLTK.LowLevel.Fl_Types+import Graphics.UI.FLTK.LowLevel.FLTKHS+import qualified Graphics.UI.FLTK.LowLevel.FL as FL+import qualified Graphics.UI.FLTK.LowLevel.GlWindow as FL+import qualified Graphics.UI.FLTK.LowLevel.Gl as FL+import qualified Graphics.UI.FLTK.LowLevel.Fl_Enumerations as FL++import Graphics.GL.Functions as GL+import Graphics.GL as GL++import Data.Text as T++import Foreign.Marshal.Array (newArray)+import Foreign.Ptr (Ptr)+import Data.IORef+import Data.Bits+import System.Environment++----------------------------------------++data Wire = Line | Polygon+data CubeState =+ CubeState+ {+ lasttime :: Double,+ wire :: Wire,+ size :: Double,+ speed :: Double+ }++data UI =+ UI+ {+ form :: Ref Window,+ speedSlider :: Ref Slider,+ sizeSlider :: Ref Slider,+ wireSelect :: Ref RadioLightButton,+ flatSelect :: Ref RadioLightButton,+ cube1 :: Ref GlWindow,+ cube2 :: Ref GlWindow,+ exit :: Ref Button+ }++----------------------------------------++v0, v1, v2, v3, v4, v5, v6, v7 :: (GL.GLfloat, GL.GLfloat, GL.GLfloat)+v0 = ( 0.0, 0.0, 0.0 );+v1 = ( 1.0, 0.0, 0.0 );+v2 = ( 1.0, 1.0, 0.0 );+v3 = ( 0.0, 1.0, 0.0 );+v4 = ( 0.0, 0.0, 1.0 );+v5 = ( 1.0, 0.0, 1.0 );+v6 = ( 1.0, 1.0, 1.0 );+v7 = ( 0.0, 1.0, 1.0 );++----------------------------------------++drawCube :: Wire -> IO ()+drawCube wire = do+ let lineOrPolygon = case wire of+ Line -> GL.GL_LINE_LOOP+ Polygon -> GL.GL_POLYGON+ cube lineOrPolygon (0,0,255) v0 v1 v2 v3+ cube lineOrPolygon (0,255,255) v4 v5 v6 v7+ cube lineOrPolygon (255,0,255) v0 v1 v5 v4+ cube lineOrPolygon (255,255,0) v2 v3 v7 v6+ cube lineOrPolygon (0,255,0) v0 v4 v7 v3+ cube lineOrPolygon (255,0,0) v1 v2 v6 v5+ where+ v3f (xCoord, yCoord, zCoord) = glVertex3f xCoord yCoord zCoord+ cube lineOrPolygon (r,g,b) vertex1 vertex2 vertex3 vertex4 =+ do+ glBegin lineOrPolygon+ glColor3ub r g b+ v3f vertex1 >> v3f vertex2 >> v3f vertex3 >> v3f vertex4+ glEnd++handleCubeWindow :: Ref GlWindow -> FL.Event -> IO (Either UnknownEvent ())+handleCubeWindow window event =+ case event of+ FL.Enter -> setCursor window FL.CursorCross >> handleSuper window event+ FL.Leave -> setCursor window FL.CursorDefault >> handleSuper window event+ _ -> handleSuper window event++drawCubeWindow :: IORef CubeState -> Ref GlWindow -> IO()+drawCubeWindow stateRef window = do+ modifyIORef stateRef (\s -> s{ lasttime = (lasttime s) + (speed s)})+ state <- readIORef stateRef+ windowValid <- getValid window+ if (not windowValid)+ then do+ glLoadIdentity+ pW <- pixelW window+ pH <- pixelH window+ glViewport (fromIntegral 0) (fromIntegral 0) (fromIntegral pW) (fromIntegral pH)+ glEnable GL.GL_DEPTH_TEST+ glFrustum (-1) 1 (-1) 1 2 10000+ glTranslatef 0 0 (-10)+ FL.glFont FL.helvetica (FontSize 16)+ else return ()+ glClear (GL.GL_COLOR_BUFFER_BIT .|. GL.GL_DEPTH_BUFFER_BIT)+ glPushMatrix+ glRotatef (realToFrac (lasttime state ) * 1.6) 0.0 0.0 1.0+ glRotatef (realToFrac (lasttime state ) * 4.2) 1.0 0.0 0.0+ glRotatef (realToFrac (lasttime state ) * 2.3) 0.0 1.0 0.0+ glTranslatef (-1.0) 1.2 (-1.5)+ let fSize = (realToFrac (size state))+ glScalef fSize fSize fSize+ drawCube (wire state)+ glPopMatrix+ FL.glColor FL.grayColor+ glDisable GL.GL_DEPTH_TEST+ let cubeLabel = case (wire state) of+ Line -> T.pack("Cube: wire")+ Polygon -> T.pack("Cube: flat")+ FL.glDrawAt cubeLabel (-4.5) (-4.5)+ glEnable GL.GL_DEPTH_TEST++----------------------------------------++main :: IO ()+main = do+ FL.setScheme "gtk+"+ FL.setUseHighResGL True+ cube1State <- newIORef (CubeState 0.0 Line 1.0 1.0)+ cube2State <- newIORef (CubeState 0.0 Polygon 1.0 1.0)+ ui <- makeForm "Cube demo" cube1State cube2State+ bounds (speedSlider ui) 4.0 0.0+ setValue (speedSlider ui) 1.0+ bounds (sizeSlider ui) 4.0 0.01+ setValue (sizeSlider ui) 1.0+ setValue (flatSelect ui) True+ showWidget (form ui)+ showWidget (cube1 ui)+ showWidget (cube2 ui)+ doUntil (eventLoopEnds ui cube1State cube2State)+ where+ eventLoopEnds ui s1 s2 = do+ let update = do+ lineDraw <- getValue (wireSelect ui)+ newSize <- getValue (sizeSlider ui)+ newSpeed <- getValue (speedSlider ui)+ mapM_+ (\(stateRef, newWire) ->+ modifyIORef+ stateRef+ (\oldState ->+ oldState+ {+ wire = newWire,+ speed = newSpeed,+ size = newSize+ }+ ))+ [(s1, if lineDraw then Line else Polygon),+ (s2, if lineDraw then Polygon else Line)]+ redraw (cube1 ui)+ redraw (cube2 ui)+ continue todo =+ if (todo == 0) then return True+ else do+ update+ FL.readqueue >>=+ maybe (return False) (\ref -> ref `refPtrEquals` (exit ui))+ isVisible <- getVisible (form ui)+ speed <- getValue (speedSlider ui)+ if (isVisible && (speed == 0))+ then FL.check >>= continue+ else FL.wait >>= continue++ doUntil action = do+ shouldStop <- action+ if shouldStop+ then return ()+ else doUntil action+ makeForm formName s1 s2 = do+ form <- windowNew (toSize (510 + 390, 390))+ Nothing+ (Just(T.pack formName))+ begin form+ b1 <- boxNew+ (toRectangle (20,20,350,350))+ Nothing+ setBox b1 FL.DownFrame+ b2 <- boxNew (toRectangle (510,20,350,350))+ Nothing+ setBox b2 FL.DownFrame+ speed <- sliderNew (toRectangle (390,90,40,220))+ (Just (T.pack "Speed"))+ setType speed VertSliderType+ size <- sliderNew (toRectangle (450,90,40,220))+ (Just (T.pack "Size"))+ setType size VertSliderType+ wire <- radioLightButtonNew (toRectangle (390,20,100,30))+ (Just (T.pack "Wire"))+ flat <- radioLightButtonNew (toRectangle (390,50,100,30))+ (Just (T.pack "Flat"))+ button <- buttonNew (toRectangle (390,340,100,30))+ (Just (T.pack "Exit"))+ cube1 <- FL.glWindowCustom+ (Size (Width 344) (Height 344))+ (Just (Position (X 23) (Y 23)))+ Nothing+ (Just (drawCubeWindow s1))+ defaultCustomWidgetFuncs{handleCustom = Just handleCubeWindow}+ defaultCustomWindowFuncs+ cube2 <- FL.glWindowCustom+ (Size (Width 344) (Height 344))+ (Just (Position (X 513) (Y 23)))+ Nothing+ (Just (drawCubeWindow s2))+ defaultCustomWidgetFuncs{handleCustom = Just handleCubeWindow}+ defaultCustomWindowFuncs+ cube1X <- getX cube1+ cube1W <- getW cube1+ cube2X <- getX cube2+ cube2W <- getW cube2+ sizeY <- getY size+ sizeH <- getH size+ b <- boxNew+ (toRectangle (cube1X, sizeY, (cube2X + cube2W) - cube1X, sizeH))+ Nothing+ setBox b FL.NoBox+ setResizable form (Just b)+ hide b+ end form+ return (UI{+ form = form,+ speedSlider = speed,+ sizeSlider = size,+ wireSelect = wire,+ flatSelect = flat,+ cube1 = cube1,+ cube2 = cube2,+ exit = button+ })++----------------------------------------