diff --git a/.gitignore b/.gitignore --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,4 @@ +result *.a *.o .\#* diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md new file mode 100644 --- /dev/null +++ b/CONTRIBUTING.md @@ -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 + diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -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") diff --git a/c-src/Fl_C.cpp b/c-src/Fl_C.cpp --- a/c-src/Fl_C.cpp +++ b/c-src/Fl_C.cpp @@ -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); } diff --git a/c-src/Fl_C.h b/c-src/Fl_C.h --- a/c-src/Fl_C.h +++ b/c-src/Fl_C.h @@ -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)); diff --git a/default.nix b/default.nix new file mode 100644 --- /dev/null +++ b/default.nix @@ -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:` + +} diff --git a/fltkhs.cabal b/fltkhs.cabal --- a/fltkhs.cabal +++ b/fltkhs.cabal @@ -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" + +---------------------------------------- diff --git a/shell.nix b/shell.nix new file mode 100644 --- /dev/null +++ b/shell.nix @@ -0,0 +1,66 @@ +{ nixpkgsPath ? +, 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 {}; + + /* + $ 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 diff --git a/src/Graphics/UI/FLTK/LowLevel/FL.chs b/src/Graphics/UI/FLTK/LowLevel/FL.chs --- a/src/Graphics/UI/FLTK/LowLevel/FL.chs +++ b/src/Graphics/UI/FLTK/LowLevel/FL.chs @@ -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 diff --git a/src/Graphics/UI/FLTK/LowLevel/PNGImage.chs b/src/Graphics/UI/FLTK/LowLevel/PNGImage.chs --- a/src/Graphics/UI/FLTK/LowLevel/PNGImage.chs +++ b/src/Graphics/UI/FLTK/LowLevel/PNGImage.chs @@ -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 -- @ diff --git a/src/Graphics/UI/FLTK/LowLevel/RGBImage.chs b/src/Graphics/UI/FLTK/LowLevel/RGBImage.chs --- a/src/Graphics/UI/FLTK/LowLevel/RGBImage.chs +++ b/src/Graphics/UI/FLTK/LowLevel/RGBImage.chs @@ -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. -- diff --git a/src/TestPrograms/Buttons.hs b/src/TestPrograms/Buttons.hs --- a/src/TestPrograms/Buttons.hs +++ b/src/TestPrograms/Buttons.hs @@ -1,4 +1,14 @@ {-# LANGUAGE OverloadedStrings #-} + +{- | Ported from [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 diff --git a/src/TestPrograms/OpenGL.hs b/src/TestPrograms/OpenGL.hs new file mode 100644 --- /dev/null +++ b/src/TestPrograms/OpenGL.hs @@ -0,0 +1,250 @@ +{-# LANGUAGE OverloadedStrings, PatternSynonyms #-} + +{- | Ported from [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 + }) + +----------------------------------------