Skip to content
Browse files

Update samples for wxWudgets 2.9

Ignore-this: 20444b06d03a9fb28374e6a9789ce02c

Update the OpenGL samples so that they work!
Add Dave Tapley's PropertyGrid sample

darcs-hash:20120325115218-75908-35f02d48a3ff8b389fa7d1cf5efdecc81391f967.gz
  • Loading branch information...
1 parent 83a2b29 commit e3fe73b7b6feb6c2feedaccc56b25a4c0c2683ee @jodonoghue committed
Showing with 122 additions and 42 deletions.
  1. +11 −17 samples/contrib/GLCanvas.hs
  2. +23 −25 samples/contrib/GLMultiCanvas.hs
  3. +88 −0 samples/wx/PropertyGrid.hs
View
28 samples/contrib/GLCanvas.hs
@@ -23,7 +23,6 @@ import Graphics.UI.WX
import Graphics.UI.WXCore
import Graphics.Rendering.OpenGL
-- Many code and Type are ambiguous, so we must qualify names.
-
import qualified Graphics.UI.WX as WX
import qualified Graphics.Rendering.OpenGL as GL
@@ -36,18 +35,14 @@ defaultHeight = 200
gui = do
f <- frame [ text := "Simple OpenGL" ]
- p <- panel f []
- glCanvas <- glCanvasCreateEx p 0 (Rect 0 0 defaultWidth defaultHeight) 0 "GLCanvas" [GL_RGBA] nullPalette
+ glCanvas <- glCanvasCreateEx f 0 (Rect 0 0 defaultWidth defaultHeight) 0 "GLCanvas" [GL_RGBA] nullPalette
glContext <- glContextCreateFromNull glCanvas
- WX.set f [ layout := container p $
- fill $
- column 5 $
- [label "Single OpenGL canvas",
- widget glCanvas
- ]
- -- you have to use the paintRaw event. Otherwise the OpenGL window won't
- -- show anything!
- , on paintRaw := paintGL glCanvas glContext
+ glCanvasSetCurrent glCanvas glContext
+ let glWidgetLayout = fill $ widget glCanvas
+ WX.set f [ layout := glWidgetLayout
+-- you have to use the paintRaw event. Otherwise the OpenGL window won't
+-- show anything!
+ , on paintRaw := paintGL glCanvas
]
convWG (WX.Size w h) = (GL.Size (convInt32 w) (convInt32 h))
@@ -55,16 +50,15 @@ convInt32 = fromInteger . toInteger
-- This paint function gets the current glCanvas for knowing where to draw in.
-- It is possible to have multiple GL windows in your application.
-paintGL :: GLCanvas a -> GLContext b -> DC() -> WX.Rect -> [WX.Rect]-> IO ()
-paintGL glWindow glContext dc myrect _ = do
- glCanvasSetCurrent glWindow glContext
+paintGL :: GLCanvas a -> DC() -> WX.Rect -> [WX.Rect]-> IO ()
+paintGL glWindow dc myrect _ = do
myInit
reshape $ convWG $ rectSize myrect
- GL.clearColor GL.$= GL.Color4 1 0 0 0
display
glCanvasSwapBuffers glWindow
return ()
+
ctrlPoints :: [[GL.Vertex3 GL.GLfloat]]
ctrlPoints = [
[ GL.Vertex3 (-1.5) (-1.5) 4.0, GL.Vertex3 (-0.5) (-1.5) 2.0,
@@ -90,7 +84,7 @@ initlights = do
myInit :: IO ()
myInit = do
- --GL.clearColor GL.$= GL.Color4 0.1 0.1 0.6 0
+ GL.clearColor GL.$= GL.Color4 0.1 0.1 0.6 0
GL.depthFunc GL.$= Just GL.Less
m <- GL.newMap2 (0, 1) (0, 1) (transpose ctrlPoints)
GL.map2 GL.$= Just (m :: GLmap2 GL.Vertex3 GL.GLfloat)
View
48 samples/contrib/GLMultiCanvas.hs
@@ -23,46 +23,44 @@ defaultHeight = 200
gui = do
f <- frame [ text := "Simple OpenGL" ]
- p <- panel f []
- -- We just create two glCanvas
- glCanvas <- glCanvasCreateEx f 0 (Rect 0 0 defaultWidth defaultHeight)
+
+-- We just create two glCanvas
+
+ glCanvas <- glCanvasCreateEx f 0 (Rect 0 0 defaultWidth defaultHeight)
0 "GLCanvas" [GL_RGBA] nullPalette
glCanvas2 <- glCanvasCreateEx f 0 (Rect 0 0 defaultWidth defaultHeight)
0 "GLCanvas" [GL_RGBA] nullPalette
- -- With two contexts
- glContext <- glContextCreateFromNull glCanvas
- glContext2 <- glContextCreateFromNull glCanvas2
-
- -- Hint: You have to use the paintRaw event. For switching between the two
- -- glwindows you can give both of them as parameter
- WX.set f [ layout := container p $
- fill $
- column 5 $
- [ label "Two OpenGL canvases"
- , widget glCanvas2
- , widget glCanvas
- ]
- , on paintRaw := paintGL glCanvas glCanvas2 glContext glContext2
+
+ let glWidgetLayout = fill $ row 5 [widget glCanvas2, widget glCanvas]
+
+-- Hint: You have to use the paintRaw event. For switching between the two
+-- glwindows you can give both of them as parameter
+ WX.set f [ layout := glWidgetLayout
+ , on paintRaw := paintGL glCanvas glCanvas2
]
convWG (WX.Size w h) = (GL.Size (convInt32 w) (convInt32 h))
convInt32 = fromInteger . toInteger
-paintGL :: GLCanvas a -> GLCanvas a -> GLContext b -> GLContext b -> DC() -> WX.Rect -> [WX.Rect]-> IO ()
-paintGL gl1 gl2 c1 c2 dc myrect _ = do
- -- Now we switch to the first one
- -- and do all init and painting stuff
- -- Hint: I changed the backgroundcolor for clearance
- glCanvasSetCurrent gl1 c1
+paintGL :: GLCanvas a -> GLCanvas a -> DC() -> WX.Rect -> [WX.Rect]-> IO ()
+paintGL gl1 gl2 dc myrect _ = do
+
+-- Now we switch to the first one
+-- and do all init and painting stuff
+-- Hint: I changed the backgroundcolor for clearance
+
+ glContext1 <- glContextCreateFromNull gl1
+ glCanvasSetCurrent gl1 glContext1
myInit
reshape $ convWG $ rectSize myrect
GL.clearColor GL.$= GL.Color4 1 0 0 0
display
glCanvasSwapBuffers gl1
- -- All the same for the second one
- glCanvasSetCurrent gl2 c2
+-- All the same for the second one
+ glContext2 <- glContextCreateFromNull gl2
+ glCanvasSetCurrent gl2 glContext2
myInit
reshape $ convWG $ rectSize myrect
GL.clearColor GL.$= GL.Color4 0 2 0 0
View
88 samples/wx/PropertyGrid.hs
@@ -0,0 +1,88 @@
+{--------------------------------------------------------------------------------
+ List control demo.
+--------------------------------------------------------------------------------}
+module Main where
+
+import Graphics.UI.WX
+import Graphics.UI.WXCore
+
+import Data.Traversable as Traversable
+
+main :: IO ()
+main
+ = start gui
+
+gui :: IO ()
+gui
+ = do -- main gui elements
+ f <- frame [text := "Property Grid Sample"]
+ -- panel: just for the nice grey color
+ p <- panel f []
+ textlog <- textCtrl p [enabled := False, wrap := WrapLine]
+
+ -- use text control as logger
+ textCtrlMakeLogActiveTarget textlog
+ logMessage "logging enabled"
+
+ -- propertyGrid
+ pg <- propertyGrid p [on propertyGridEvent := onPropertyGridEvent]
+
+ -- add test data
+ propertyCategoryCreate "alpha" >>= propertyGridAppend pg
+ stringPropertyCreate "Name" "name" "Bob" >>= propertyGridAppend pg
+ propertyGridDisableProperty pg "name"
+
+ intPropertyCreate "Age" "age" 32 >>= propertyGridAppend pg
+ boolPropertyCreate "Is member?" "bool" True >>= propertyGridAppend pg
+
+ propertyCategoryCreate "beta" >>= propertyGridAppend pg
+ floatPropertyCreate "Score" "float" 3.14 >>= propertyGridAppend pg
+ dateTimeCreate >>= \d -> dateTimeNow d >> datePropertyCreate "Join date" "date" d >>= propertyGridAppend pg
+ filePropertyCreate "Data file" "file" "/home/" >>= propertyGridAppend pg
+
+ -- specify layout
+ set f [layout := container p $ margin 10 $
+ column 5 [ fill $ widget pg
+ , hfill $ widget textlog
+ ]
+ ,clientSize := sz 600 400
+ ]
+ return ()
+
+ where
+ onPropertyGridEvent eventPropertyGrid
+ = case eventPropertyGrid of
+ PropertyGridChanged prop ->
+ showProp prop >>= logMessage . (++) "PropertyGrid changed "
+
+ PropertyGridHighlighted maybeProp ->
+ let propStr = show `fmap` (showProp `Traversable.mapM` maybeProp)
+ in propStr >>= logMessage . (++) "PropertyGrid highlighted "
+
+ other ->
+ logMessage ("Other propertyGrid event.")
+
+ showProp p = do
+ label <- pGPropertyGetLabel p
+ typeString <- pGPropertyGetValueType p
+ valueString <- pGPropertyGetValueAsString p
+ return $ label ++ " " ++ show (readAny typeString valueString)
+
+data Any
+ = IsString String
+ | IsInteger Integer
+ | IsBool Bool
+ | IsDouble Double
+ | IsDateTime String
+ | IsUndefined
+ deriving (Eq, Show)
+
+readAny :: String -> String -> Any
+readAny typeStr valueStr = maybe IsUndefined ($ valueStr) (lookup typeStr typeMap)
+ where typeMap =
+ [ ("string", IsString)
+ , ("long", IsInteger . read)
+ , ("bool", IsBool . read)
+ , ("double", IsDouble . read)
+ , ("datetime", IsDateTime) ]
+

0 comments on commit e3fe73b

Please sign in to comment.
Something went wrong with that request. Please try again.