packages feed

wxFruit (empty) → 0.1

raw patch · 5 files changed

+966/−0 lines, 5 filesdep +Yampadep +basedep +old-timesetup-changed

Dependencies added: Yampa, base, old-time, wx, wxcore

Files

+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) 2004, Antony Courtney, Bart Robinson, Paul Hudak ++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright notice,+      this list of conditions and the following disclaimer.+    * Redistributions in binary form must reproduce the above copyright notice,+      this list of conditions and the following disclaimer in the documentation+      and/or other materials provided with the distribution.+    * Neither the name of the Maybench developers nor the names of its+      contributors may be used to endorse or promote products derived from this+      software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR+CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,+EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,+PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR+PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING+NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ WXFruit.hs view
@@ -0,0 +1,811 @@+-----------------------------------------------------------
+-- WXFruit: an implementation of Fruit using wxHaskell.
+--   Version 0.1, May 2004
+--   Contributors: Antony Courtney, Bart Robinson
+-----------------------------------------------------------
+
+module WXFruit where
+
+-----------------------------------------------------------
+-- Module imports.
+
+import qualified Graphics.UI.WX as WX
+import qualified Graphics.UI.WXCore as WXCore
+import AFRP
+import AFRPUtilities
+import Control.Arrow
+
+import Data.IORef
+import System.Time
+
+
+-----------------------------------------------------------
+-- Data types for communication between widgets and the
+-- system.  (These are likely to change dramatically.)
+
+-- Raw input: kind of a hack...
+data WXRawInput = WXRawInput {
+     wxMousePos :: WX.Point -- relative to topmost frame
+     -- add other raw inputs here: keyboard, mouse presses?
+  }
+
+-- Responses/Requests: This is rather clumsy, as any new
+-- widgets would have to add their own alternatives to
+-- these sums.  A way to do more dynamic run-time typing
+-- could help with this problem.
+data WXWidgetResp = WXWInit -- currently not used
+                  | WXWButtonCreateResp (WX.Button ())
+                  | WXWTextCreateResp (WX.StaticText ())
+                  | WXWPictureCreateResp (WX.Panel ())
+                  | WXWSliderCreateResp (WX.Slider ())
+                  | WXWButtonCommandEvent -- button pressed
+                  | WXWSliderCommandEvent Int -- new value selected
+                  | WXWDeComp (Event WXWidgetResp,Event WXWidgetResp)
+
+data WXWidgetReq = WXWButtonCreateReq WXButtonState
+                 | WXWTextCreateReq WXTextState
+                 | WXWPictureCreateReq WXPictureState
+                 | WXWSliderCreateReq WXSliderState
+                 | WXWButtonSetReq (WX.Button ()) WXButtonState
+                 | WXWTextSetReq (WX.StaticText ()) WXTextState
+                 | WXWPictureSetReq (WX.Panel ()) WXPictureState
+                 | WXWSliderSetReq (WX.Slider ()) WXSliderState
+                 | WXWComp Orientation (Event WXWidgetReq,Event WXWidgetReq)
+
+data Orientation = Horiz | Vert
+  deriving (Eq)
+
+
+-----------------------------------------------------------
+-- Widgets, GUIs, and Boxes.  The basic WXFruit building
+-- blocks.
+
+-- Widget: just a fancy signal function.
+type Widget a b = SF (WXRawInput,Event WXWidgetResp,a) (Event WXWidgetReq,b)
+
+-- WXGUI: conceptually the same as a Widget, but a newtype
+-- is used so that it can be made into an Arrow.
+newtype WXGUI b c = WXGUI (Widget b c)
+
+-- WXGUI functions for Arrow instance.  This makes WXGUI
+-- correspond to the GA type in the original Fruit.  I'm
+-- not actually not sure this is necessary, because the
+-- preferred idiom is to use WXBoxes, anyway.
+
+-- Lifting/lowering
+
+wxUnGUI :: WXGUI b c -> Widget b c
+wxUnGUI (WXGUI w) = w
+
+wxSF :: SF b c -> WXGUI b c
+wxSF sf = WXGUI $ proc (_,_,b) -> do
+  c <- sf -< b
+  returnA -< (noEvent,c)
+
+wxArr :: (b -> c) -> WXGUI b c
+wxArr f = wxSF (arr f)
+
+-- Composing: handles the "plumbing" involved in composing
+-- widgets together -- makes sure the system input/output
+-- streams are hooked up correctly.  The ugliness this
+-- hides is basically the motivation for creating an Arrow
+-- instance for WXGUI (and WXBox).
+
+decompResp :: Event WXWidgetResp -> (Event WXWidgetResp,Event WXWidgetResp)
+decompResp (Event WXWInit) = (Event WXWInit,Event WXWInit)
+decompResp (Event (WXWDeComp (resp0,resp1))) = (resp0,resp1)
+decompResp _ = (noEvent,noEvent)
+
+compReq :: Orientation -> Event WXWidgetReq -> Event WXWidgetReq -> Event WXWidgetReq
+compReq _ NoEvent NoEvent = noEvent
+compReq orient req0 req1 = Event (WXWComp orient (req0,req1))
+
+-- Composition generalized over orientations
+wxGComp :: Orientation -> WXGUI b c -> WXGUI c d -> WXGUI b d
+wxGComp orient (WXGUI w1) (WXGUI w2) = WXGUI $ proc (inp,resp,b) -> do
+  let (resp1,resp2) = decompResp resp
+  (req1,c) <- w1 -< (inp,resp1,b)
+  (req2,d) <- w2 -< (inp,resp2,c)
+  returnA -< (compReq orient req1 req2,d)
+
+-- Default layout for composed widgets is horizontal.
+wxComp :: WXGUI b c -> WXGUI c d -> WXGUI b d
+wxComp = wxGComp Horiz
+
+wxFirst :: WXGUI b c -> WXGUI (b,d) (c,d)
+wxFirst (WXGUI w) = WXGUI $ proc (inp,resp,(b,d)) -> do
+  (req,c) <- w -< (inp,resp,b)
+  returnA -< (req,(c,d))
+
+instance Arrow WXGUI where
+  arr = wxArr
+  (>>>) = wxComp
+  first = wxFirst
+
+wxLoop :: WXGUI (b,d) (c,d) -> WXGUI b c
+wxLoop (WXGUI w) = WXGUI $ proc (inp,resp,b) -> do
+  rec (req,(c,d)) <- w -< (inp,resp,(b,d))
+  returnA -< (req,c)
+
+instance ArrowLoop WXGUI where
+  loop = wxLoop
+
+-- WXBox: Builds upon WXGUI, adding the ability to defer
+-- the specification of the orientation of a collection of
+-- widgets.
+
+newtype WXBox b c = WXBox (Orientation -> WXGUI b c)
+
+-- Lift a GUI into a Box, keeping the GUI's internal
+-- orientation(s)
+wxBox :: WXGUI b c -> WXBox b c
+wxBox w = WXBox (const w)
+
+-- Compose Boxes by threading orientation to children.
+wxCompBox :: WXBox b c -> WXBox c d -> WXBox b d
+wxCompBox (WXBox b1f) (WXBox b2f) = WXBox $
+  \orient -> wxGComp orient (b1f orient) (b2f orient)
+
+wxFirstBox :: WXBox b c -> WXBox (b,d) (c,d)
+wxFirstBox (WXBox bf) = WXBox $ \orient -> first (bf orient)
+
+instance Arrow WXBox where
+  arr = wxBox . arr
+  (>>>) = wxCompBox
+  first = wxFirstBox
+
+wxLoopBox :: WXBox (b,d) (c,d) -> WXBox b c
+wxLoopBox (WXBox bf) = WXBox $ \orient -> loop (bf orient)
+
+instance ArrowLoop WXBox where
+  loop = wxLoopBox
+
+-- Some useful Box functions
+
+wxBoxGUI :: Widget b c -> WXBox b c
+wxBoxGUI = wxBox . WXGUI
+
+wxBoxSF :: SF b c -> WXBox b c
+wxBoxSF = wxBox . wxSF
+
+-- These two are used to surround collections of Boxes and
+-- make them go left-to-right or top-to-bottom.  They both
+-- have the same effect when applied to a WXBox containing
+-- just a single widget.
+
+wxHBox :: WXBox b c -> WXGUI b c
+wxHBox (WXBox bf) = bf Horiz
+
+wxVBox :: WXBox b c -> WXGUI b c
+wxVBox (WXBox bf) = bf Vert
+
+
+-----------------------------------------------------------
+-- Individual Widget definitions.  These are defined as
+-- WXBoxes to allow easy composition.  They all employ a
+-- similar pattern: they have a state-modifier function as
+-- input, and use the same internal idioms to communicate
+-- with the system.  See Button for extensive comments.
+--   As more of these are added, it might be helpful to
+-- move them into other modules/files.  (Which might be
+-- tricky, as they are currently closed tied up with the
+-- response/request data types.)
+
+-- Utility to detect when a widget's state has changed
+maybeChanged :: Eq a => a -> a -> Maybe ()
+maybeChanged s s' = if s == s' then Nothing else Just ()
+
+
+-----------------------------------------------------------
+-- Button widget: has a string label, can be enabled and
+-- disabled, and outputs an Event () when pressed
+
+-- State
+
+data WXButtonState = WXButtonState {
+     bsLabel :: String,
+     bsEnabled :: Bool
+  } deriving (Eq, Show)
+
+type WXButtonConf = WXButtonState -> WXButtonState
+
+-- Constructors to initialize and alter state.  Note that
+-- the state of a button should not (cannot?) be modified
+-- other than through the use of these functions.
+
+btext :: String -> WXButtonConf
+btext l bs = bs {bsLabel = l}
+
+benabled :: Bool -> WXButtonConf
+benabled e bs = bs {bsEnabled = e}
+
+-- The button GUI
+
+wxbutton :: WXButtonConf -> WXBox WXButtonConf (Event ())
+wxbutton conf0 =
+  let -- Initial state
+      defState = WXButtonState {bsLabel = "Default", bsEnabled = True}
+      initState = conf0 defState
+      
+      -- Detect creation
+      maybeCreate (WXWButtonCreateResp b) = Just (True,b)
+      maybeCreate _ = Nothing
+      
+      -- Detect button press
+      maybeCommand WXWButtonCommandEvent = Just ()
+      maybeCommand _ = Nothing
+  
+  -- Make an ordinary, atomic signal function (in order to have access
+  -- to the response/request mechanism), then lift it into a WXBox
+  -- with wxBoxGUI.
+  in wxBoxGUI $ proc (_,resp,conf) -> do
+    -- Keep track of the state.
+    rec state <- iPre initState -< conf state
+    
+    -- Has the state changed?  If so, generate set request.
+    stateChanged <- edgeBy maybeChanged initState -< state
+    
+    -- Ensure that the system hands us back a WX.Button ().
+    (isCreated,button) <- hold (False,undefined) -< mapFilterE maybeCreate resp
+        
+    -- Send a creation request if we haven't been created yet.
+    -- WARNING: this is probably a bad way to do this.  It can
+    -- create an infinitely-dense stream of Events, which is a
+    -- big no-no in the AFRP world (at least, conceptually).
+    -- We used to use WXWInit for this purpose, but with the
+    -- dynamic switching of widgets, the system wouldn't know
+    -- when to send the WXWInit events to widgets that have
+    -- been switched-into.
+    let doCreate = if isCreated then noEvent else Event ()
+    
+    -- Merge create/set requests.
+    let req = lMerge (tag doCreate (WXWButtonCreateReq state))
+                     (tag stateChanged (WXWButtonSetReq button state))
+    
+    -- Pass button presses through.
+    let press = mapFilterE maybeCommand resp
+    
+    returnA -< (req,press)
+
+
+-----------------------------------------------------------
+-- Static text (label) widget: Displays a string, and has
+-- no output.
+
+-- State
+
+data WXTextState = WXTextState {            
+     tsLabel :: String
+  } deriving (Eq, Show)
+
+type WXTextConf = WXTextState -> WXTextState
+
+-- Constructor
+
+ttext :: String -> WXTextConf
+ttext l ts = ts {tsLabel = l}
+
+-- The text GUI
+
+wxtext :: WXTextConf -> WXBox WXTextConf ()
+wxtext conf0 = 
+  let -- Initial state
+      defState = WXTextState {tsLabel = "Default"}
+      initState = conf0 defState
+      
+      -- Detect creation
+      maybeCreate (WXWTextCreateResp t) = Just (True,t)
+      maybeCreate _ = Nothing
+  
+  in wxBoxGUI $ proc (_,resp,conf) -> do
+    -- State
+    rec state <- iPre initState -< conf state
+    stateChanged <- edgeBy maybeChanged initState -< state
+    
+    -- Creation
+    (isCreated,text) <- hold (False,undefined) -< mapFilterE maybeCreate resp
+    let doCreate = if isCreated then noEvent else Event ()
+    
+    -- Output
+    let req = lMerge (tag doCreate (WXWTextCreateReq state))
+                     (tag stateChanged (WXWTextSetReq text state))
+    returnA -< (req,())
+
+
+-----------------------------------------------------------
+-- Slider widget: a slider that the user can move along a
+-- bar between minimum and maximum values.  Can be oriented
+-- horizontally or vertically (upon creation), and
+-- enabled/disabled dynamically.  Outputs a continuous
+-- signal indicating the currently-selected value.
+
+-- State
+
+data WXSliderState = WXSliderState {
+     -- These properties are determined upon creation,
+     -- and cannot be subsequently altered.
+     ssMin :: Int,
+     ssMax :: Int,
+     ssOrientation :: Orientation,
+     
+     ssSelection :: Int, -- user- and programmer-modifiable
+     ssEnabled :: Bool -- programmer-modifiable
+  } deriving (Eq)
+
+type WXSliderConf = WXSliderState -> WXSliderState
+
+-- Constructors
+
+senabled :: Bool -> WXSliderConf
+senabled e ss = ss {ssEnabled = e}
+
+sselection :: Int -> WXSliderConf
+sselection sel ss = ss {ssSelection = sel}
+
+-- The slider GUI
+
+wxslider :: Orientation -> Int -> Int -> WXSliderConf -> WXBox WXSliderConf Int
+wxslider orient min max conf0 =
+  let -- Initial state
+      defState = WXSliderState
+        {ssMin = min, ssMax = max, ssOrientation = orient,
+         ssSelection = 0, ssEnabled = True}
+      initState = conf0 defState
+      
+      -- Change state when user moves slider
+      changeSel state (Event (WXWSliderCommandEvent sel)) =
+        state {ssSelection = sel}
+      changeSel state _ = state
+      
+      -- Define our own maybeChanged, because we don't want to generate
+      -- a WXWSliderSetReq if the only change in the state that occurred
+      -- was via user input.
+      maybeChangedInternal (_,state) (Event (WXWSliderCommandEvent _), state') =
+        if (state {ssSelection = ssSelection state'}) == state'
+          then Nothing
+          else Just () 
+      maybeChangedInternal (_,state) (_,state') =
+        maybeChanged state state'
+      
+      -- Detect creation
+      maybeCreate (WXWSliderCreateResp s) = Just (True,s)
+      maybeCreate _ = Nothing
+      
+  in wxBoxGUI $ proc (_,resp,conf) -> do
+    -- State
+    rec let newState = changeSel (conf state) resp
+        state <- iPre initState -< newState
+    
+    -- Detect actionable state changes
+    stateChanged <- edgeBy maybeChangedInternal (noEvent,initState) -< (resp,state)
+    
+    -- Creation
+    (isCreated,slider) <- hold (False,undefined) -< mapFilterE maybeCreate resp
+    let doCreate = if isCreated then noEvent else Event ()
+    
+    -- Output
+    let req = lMerge (tag doCreate (WXWSliderCreateReq state))
+                     (tag stateChanged (WXWSliderSetReq slider state))
+    returnA -< (req,ssSelection state)
+
+
+-----------------------------------------------------------
+-- Picture widget: a box for doing arbitrary graphics.
+-- Uses a WX.Panel () with a custom repaint handler.
+
+-- State
+
+data WXPictureState = WXPictureState {
+    psSize :: WX.Size,
+    psPicture :: WXPicture
+  }
+
+type WXPictureConf = WXPictureState -> WXPictureState
+
+-- Constructors
+
+ppic :: WXPicture -> WXPictureConf
+ppic pic ps = ps {psPicture = pic}
+
+psize :: WX.Size -> WXPictureConf
+psize size ps = ps {psSize = size}
+
+-- The picture GUI
+
+wxpicture :: WXPictureConf -> WXBox WXPictureConf ()
+wxpicture conf0 =
+  let -- Initial state
+      defState = WXPictureState {psSize = WX.sizeNull, psPicture = wxblank}
+      initState = conf0 defState
+      
+      -- Detect creation
+      maybeCreate (WXWPictureCreateResp panel) = Just (True,panel)
+      maybeCreate _ = Nothing
+      
+  in wxBoxGUI $ proc (_,resp,conf) -> do
+    -- State
+    rec state <- iPre initState -< conf state
+    
+    -- Creation
+    (isCreated,panel) <- hold (False,undefined) -< mapFilterE maybeCreate resp
+    let doCreate = if isCreated then noEvent else Event ()
+    
+    -- Output.  Note that here we are again violating the
+    -- rules of AFRP by sending an infinitely-dense stream
+    -- of events, because we want a new picture at every
+    -- sample time so that animation will work.
+    let req = lMerge (tag doCreate (WXWPictureCreateReq state))
+                     (Event (WXWPictureSetReq panel state))
+    returnA -< (req,())
+
+
+-----------------------------------------------------------
+-- Mouse widget: this is problematic.  It just outputs the
+-- current mouse position, relative to the client space of
+-- the topmost frame.  There is currently no way to
+-- translate this into coordinates relative to a particular
+-- widget.
+
+wxmouse :: WXBox () WX.Point
+wxmouse = wxBoxGUI $ proc (inp,_,_) -> do
+  returnA -< (noEvent,wxMousePos inp)
+
+
+-----------------------------------------------------------
+-- The WXFruit graphics library!  (Just wrappers for
+-- wxHaskell functions, basically, adapting them to the
+-- SOE/Haven graphics idiom.)  Just enough is implemented
+-- here to get paddleball working.
+
+-- Picture type: This corresponds to a wxHaskell repaint handler.
+type WXPicture = [WX.Prop (WX.DC ())] -> WX.DC () -> WX.Rect -> IO ()
+
+-- Draw nothing.
+wxblank :: WXPicture
+wxblank _ _ _ = return () 
+
+-- Fill the picture with a single color.
+wxfill :: WXPicture
+wxfill props dc rect = wxPicFill (wxrect rect) props dc rect
+
+-- Draw an ellipse bounded by a rectangle.
+wxellipse :: WX.Rect -> WXPicture
+wxellipse rect props dc _ = WX.ellipse dc rect props
+
+-- Draw a rectangle.
+wxrect :: WX.Rect -> WXPicture
+wxrect rect props dc _ = WX.drawRect dc rect props
+
+-- Write graphical text.  Don't confuse this with wxtext;
+-- it's an entirely different animal.
+wxwrite :: String -> WX.Point -> WXPicture
+wxwrite str pt props dc _ = WX.drawText dc str pt props
+
+-- Make drawings use a particular color.
+wxWithColor :: WX.Color -> WXPicture -> WXPicture
+wxWithColor color pic props =
+  pic (props ++ [WX.color WX.:= color, WX.brushColor WX.:= color])
+
+-- Make rectangles and ellipses be filled in.
+wxPicFill :: WXPicture -> WXPicture
+wxPicFill pic props =
+  pic (props ++ [WX.brushKind WX.:= WX.BrushSolid])
+
+-- Combine two drawings.
+wxPicOver :: WXPicture -> WXPicture -> WXPicture
+wxPicOver pic1 pic2 props dc rect = do
+  pic2 props dc rect
+  pic1 props dc rect
+
+
+-----------------------------------------------------------
+-- Data types and functions for composition of widgets.
+-- This is where the connection is made between the tree-
+-- structure of WXGUIs and WXBoxes and the actual layout
+-- of widgets sent to wxHaskell.  This is all rather
+-- clumsy.
+
+-- Contents widget tree: wxFruit version of WX.Layout.
+data WXContents = WXCEmpty
+                | WXCLeaf WXWidget
+                | WXCComp Orientation WXContents WXContents
+
+data WXWidget = WXButton (WX.Button ())
+              | WXText (WX.StaticText ())
+              | WXPicture (WX.Panel ())
+              | WXSlider (WX.Slider ())
+
+-- Compositional path to a widget.  A True entry means
+-- go down the left/top branch of a WXContents tree; False
+-- means go down the right/bottom.
+type WXPath = [Bool]
+
+-- Convert contents into layout.  The tricky part is
+-- making sure that nested WXCComps with the same
+-- orientation are merged into a single list (see
+-- c2lList).
+contents2layout :: WXContents -> WX.Layout
+contents2layout WXCEmpty = WX.empty
+contents2layout (WXCLeaf (WXButton b)) = WX.widget b
+contents2layout (WXCLeaf (WXText t)) = WX.widget t
+contents2layout (WXCLeaf (WXPicture p)) = WX.widget p
+contents2layout (WXCLeaf (WXSlider s)) = WX.widget s
+contents2layout comp@(WXCComp orient c1 c2) =
+  (if orient == Horiz then WX.row else WX.column) 5 (c2lList orient comp)
+
+-- Merge similarly-orientated WXCComps together.
+c2lList :: Orientation -> WXContents -> [WX.Layout]
+c2lList orient comp@(WXCComp orient' c1 c2) =
+  if orient == orient'
+    then (c2lList orient c1) ++ (c2lList orient c2)
+    else [contents2layout comp]
+c2lList _ WXCEmpty = []
+c2lList _ c = [contents2layout c]
+
+-- Destroy the windows in a contents tree.  This shouldn't
+-- really be necessary, except wxHaskell doesn't currently
+-- handle window destruction properly (IMO) -- simply
+-- resetting the layout doesn't get rid of any windows
+-- in the old layout.  This is really only needed if/when
+-- widget-switching is implemented.
+removeContents :: WX.Frame () -> WXContents -> IO Bool
+removeContents f WXCEmpty = return True
+removeContents f (WXCLeaf (WXButton b)) = WXCore.windowDestroy b
+removeContents f (WXCLeaf (WXText t)) = WXCore.windowDestroy t
+removeContents f (WXCLeaf (WXSlider s)) = WXCore.windowDestroy s
+removeContents f (WXCLeaf (WXPicture p)) = WXCore.windowDestroy p
+removeContents f (WXCComp _ c0 c1) =
+  do removeContents f c0
+     removeContents f c1
+
+
+-----------------------------------------------------------
+-- The guts of the WXFruit system.  This is where the
+-- connection between wxHaskell and Yampa is made.
+
+-- State maintained across calls to react: the frame
+-- window, the time of the last sample, and the contents
+-- of the window (i.e. the entire widget tree).
+type WXGUIState = (WX.Frame (),Int,WXContents)
+type WXGUIRef = IORef WXGUIState
+
+type WXRHandle = ReactHandle (WXRawInput,Event WXWidgetResp,()) (Event WXWidgetReq,())
+
+-- Start a WXGUI running in a top-level frame.
+startGUI :: String -> WXGUI () () -> IO ()
+startGUI title (WXGUI g) = WX.start $ do
+  -- Set up frame window and internal state.
+  f <- WX.frame [WX.text WX.:= title]
+  epoch <- getCurrentTime  
+  gsr <- newIORef (f,epoch,WXCEmpty)
+  
+  -- Initialize Yampa.
+  rh <- reactInit (initSense f) (actuate gsr) g
+  
+  -- Set up heartbeat timer to make periodic calls to react.
+  -- This is necessary for animation.  Note that this is
+  -- not the only place react is called from: button
+  -- presses and other user actions may generate calls of
+  -- their own.
+  timer <- WX.timer f [WX.interval WX.:= 30, WX.on WX.command WX.:= respond gsr rh noEvent]
+  
+  return ()
+
+-- Get an input sample from the OS.
+getRawInput :: WX.Frame () -> IO WXRawInput
+getRawInput f = do
+  mouse <- WXCore.windowGetMousePosition f
+  return WXRawInput {wxMousePos = mouse}
+
+-- The very first input sample.
+initSense :: WX.Frame () -> IO (WXRawInput,Event WXWidgetResp,())
+initSense f = do
+  inp <- getRawInput f
+  return (inp,Event WXWInit,())
+
+-- Push an input sample/widget response.
+respond :: WXGUIRef -> WXRHandle -> Event WXWidgetResp -> IO ()
+respond gsr rh resp = do
+  -- Obtain input sample.
+  (f,prevt,c) <- readIORef gsr
+  inp <- getRawInput f
+  
+  -- Make sure time's elapsed since the last call to react.
+  -- With the timer set up in startGUI, this is probably
+  -- unnecessary, but we'll leave it in to be safe.
+  et <- getCurrentTime
+  (dtf,t) <- ensureTimeElapses prevt et getCurrentTime
+  writeIORef gsr (f,t,c)
+  
+  -- Let Yampa work its magic.
+  react rh (dtf,Just (inp,resp,()))
+  return ()
+
+-- Process an output sample (i.e. a widget request).
+actuate :: WXGUIRef -> WXRHandle -> Bool -> (Event WXWidgetReq,()) -> IO Bool
+actuate gsr rh _ (wre,_) = 
+  do -- Handle requests, if any.
+     (f,t,prevc) <- readIORef gsr
+     (resp,c,cch) <- handleWidgetReq gsr rh f [] prevc wre
+     
+     -- Reset layout if contents changed.
+     if cch
+       then do WX.set f [WX.layout WX.:= WX.margin 5 (contents2layout c)]
+               WX.windowReLayoutMinimal f
+       else return ()
+     writeIORef gsr (f,t,c)
+     
+     -- Turn around and respond to the widgets, if necessary.
+     -- Note that this causes a reentrant call to react.
+     case resp of
+       NoEvent -> return ()
+       _ -> respond gsr rh resp
+     
+     return False
+
+-- Handle a single widget request by making the appropriate
+-- calls into wxHaskell.  Returns a response to the
+-- request (if any), the new contents of the window, and
+-- a boolean indicating whether the contents have changed.
+handleWidgetReq :: WXGUIRef -> WXRHandle -> WX.Frame ()
+                   -> WXPath -> WXContents -> (Event WXWidgetReq)
+                   -> IO (Event WXWidgetResp,WXContents,Bool)
+
+-- Do nothing if no request.
+handleWidgetReq _ _ _ _ c NoEvent = return (noEvent,c,False)
+
+-- Handle creation by calling the wxHaskell constructor with
+-- properties corresponding to the given initial state,
+-- removing any old contents, and returning the new widget.
+handleWidgetReq gsr rh f path c (Event (WXWButtonCreateReq bstate)) =
+  do let bprops = mkButtonProps gsr rh path bstate
+     b <- WX.smallButton f bprops
+     removeContents f c
+     return (Event (WXWButtonCreateResp b),WXCLeaf (WXButton b),True)
+handleWidgetReq _ _ f path c (Event (WXWTextCreateReq tstate)) =
+  do let tprops = mkTextProps tstate
+     t <- WX.staticText f tprops
+     removeContents f c
+     return (Event (WXWTextCreateResp t),WXCLeaf (WXText t),True)
+handleWidgetReq _ _ f path c (Event (WXWPictureCreateReq pstate)) =
+  do let pprops = mkPictureProps pstate
+     p <- WX.panel f pprops
+     removeContents f c
+     return (Event (WXWPictureCreateResp p),WXCLeaf (WXPicture p),True)
+handleWidgetReq gsr rh f path c (Event (WXWSliderCreateReq sstate)) =
+  do -- Here we create the slider before setting up its properties
+     -- because the event handler in the properties needs a pointer
+     -- to the slider.
+     s <- (if ssOrientation sstate == Horiz then WX.hslider else WX.vslider)
+            f False (ssMin sstate) (ssMax sstate) []
+     let sprops = mkSliderProps gsr rh path s sstate
+     WX.set s sprops
+     removeContents f c
+     return (Event (WXWSliderCreateResp s),WXCLeaf (WXSlider s),True)
+
+-- Handle creation requests by resetting the properties
+-- of the widget.
+handleWidgetReq gsr rh f path c (Event (WXWButtonSetReq b bstate)) =
+  do let bprops = mkButtonProps gsr rh path bstate
+     WX.set b bprops
+     return (noEvent,c,False)
+handleWidgetReq _ _ f path c (Event (WXWTextSetReq t tstate)) =
+  do let tprops = mkTextProps tstate
+     WX.set t tprops
+     return (noEvent,c,False)
+handleWidgetReq _ _ f path c (Event (WXWPictureSetReq p pstate)) =
+  do let pprops = mkPictureProps pstate
+     WX.set p pprops
+     WX.repaint p -- paint the new picture
+     return (noEvent,c,False)
+handleWidgetReq gsr rh f path c (Event (WXWSliderSetReq s sstate)) =
+  do -- Note that if properties other than the selection and
+     -- enable are modified, this will not change them.
+     let sprops = mkSliderProps gsr rh path s sstate
+     WX.set s sprops
+     return (noEvent,c,False)
+
+-- Pass requests down the widget tree.
+handleWidgetReq gsr rh f path c (Event (WXWComp orient (lreq,rreq))) =
+  do (lresp,lc',lcch) <- handleWidgetReq gsr rh f (True:path) (subCont True c) lreq
+     (rresp,rc',rcch) <- handleWidgetReq gsr rh f (False:path) (subCont False c) rreq
+     -- If both children returned no response, don't compose
+     -- them together.
+     return (case (lresp,rresp) of
+               (NoEvent,NoEvent) -> noEvent
+               resp -> Event (WXWDeComp resp),
+             WXCComp orient lc' rc',lcch || rcch)
+  where subCont which (WXCComp _ l r) =
+          if which then l else r
+        subCont _ _ = WXCEmpty -- contents tree has not been set up yet
+
+-- Construct button properties list
+mkButtonProps :: WXGUIRef -> WXRHandle -> WXPath -> WXButtonState
+                 -> [WX.Prop (WX.Button ())]
+mkButtonProps gsr rh path bs =
+  [WX.text WX.:= bsLabel bs, WX.enabled WX.:= bsEnabled bs,
+   WX.on WX.command WX.:= mkButtonCommand gsr rh path]
+
+-- Button-press event handler.  Causes a call to react.
+mkButtonCommand :: WXGUIRef -> WXRHandle -> WXPath -> IO ()
+mkButtonCommand gsr rh path =
+  do let e = pathify (Event WXWButtonCommandEvent) path
+     respond gsr rh e
+
+-- Contruct text label properties list.
+mkTextProps :: WXTextState -> [WX.Prop (WX.StaticText ())]
+mkTextProps ts =
+  [WX.text WX.:= tsLabel ts]
+
+-- Construct slider properties list.
+mkSliderProps :: WXGUIRef -> WXRHandle -> WXPath
+                 -> WX.Slider () -> WXSliderState -> [WX.Prop (WX.Slider ())]
+mkSliderProps gsr rh path s ss =
+  [WX.enabled WX.:= ssEnabled ss, WX.selection WX.:= ssSelection ss,
+   WX.on WX.command WX.:= mkSliderCommand gsr rh path s]
+
+-- Event handler called when slider is moved by user.
+-- Causes a call to react.
+mkSliderCommand :: WXGUIRef -> WXRHandle -> WXPath -> WX.Slider () -> IO ()
+mkSliderCommand gsr rh path s =
+  do sel <- WX.get s WX.selection
+     let e = pathify (Event (WXWSliderCommandEvent sel)) path
+     respond gsr rh e
+
+-- Construct picture widget properties list.
+mkPictureProps :: WXPictureState -> [WX.Prop (WX.Panel ())]
+mkPictureProps ps =
+  [WX.clientSize WX.:= psSize ps, WX.on WX.paint WX.:= psPicture ps []]
+
+-- Construct a WXWidgetResp corresponding to a given
+-- path.  This response will then be directed to the
+-- correct widget (e.g. a button-pressed event will be sent
+-- through the widget tree to the appropriate wxbutton).
+pathify :: Event WXWidgetResp -> WXPath -> Event WXWidgetResp
+pathify e [] = e
+pathify e (True:path) = pathify (Event (WXWDeComp (e,noEvent))) path
+pathify e (False:path) = pathify (Event (WXWDeComp (noEvent,e))) path
+
+
+-----------------------------------------------------------
+-- Utility functions copied from Yampa.
+
+getCurrentTime :: IO Int
+getCurrentTime =
+  do (TOD sec psec) <- getClockTime
+     let usec = fromIntegral psec / 1000000
+     let msec = (fromIntegral ((sec - ctEpoch) * 1000)) + (usec / 1000)
+     -- let dmsec = (fromIntegral $ msec) :: Double
+     let imsec = round msec
+     -- putStrLn ("getCurrentTime(): sec == " ++ show sec ++ ", usec == " ++
+     --           show usec)
+     -- putStrLn ("getCurrentTime() returning: " ++ (show imsec))
+     return imsec
+  where
+    -- an arbitrary epoch, in seconds, to prevent Int wraparound:
+    ctEpoch :: Integer
+    ctEpoch = 1037286000
+
+
+-- ensure an observable amount of time elapses by busy-waiting.
+--
+-- arguments:
+--   t0 :: Int -- time of last sample
+--   t1 :: Int -- current time, in milliseconds
+--   getTime :: IO Int -- returns the current time, in milliseconds
+-- result: (dtf,t1)
+--   dtf -- the elapsed time since last sample, in seconds, as a Float
+--   t1 -- the current time, in millisec.
+--
+-- We perform the floating point conversion, and perform our comparison
+-- with respect to that conversion here to ensure that we are using
+-- the same test as used by reactimate.
+--
+ensureTimeElapses :: Int -> Int -> IO Int -> IO (Double,Int)
+ensureTimeElapses t0 t1 getTime = do
+  let dt = t1 - t0
+      dtf = (fromIntegral dt) / 1000
+  if (dtf > 0) then return (dtf,t1)
+               else do t' <- getTime
+                       ensureTimeElapses t0 t' getTime
+
+ paddle.hs view
@@ -0,0 +1,93 @@+-----------------------------------------------------------
+-- PaddleBall in wxFruit.
+--   Adapted from paddleball sample in the original Fruit.
+--   Adds a slider controlling the velocity of the ball
+--   and a restart button.
+-----------------------------------------------------------
+
+module Main where
+
+import WXFruit
+import AFRP
+import AFRPUtilities
+import Control.Arrow
+import qualified Graphics.UI.WX as WX
+
+-- Elements of the game.
+
+bg :: WXPicture
+bg = wxWithColor WX.white wxfill
+
+walls :: WXPicture
+walls = let upper = wxPicFill (wxrect (WX.rect (WX.point 10 10) (WX.sz 200 10)))
+            left = wxPicFill (wxrect (WX.rect (WX.point 10 10) (WX.sz 10 200)))
+            right = wxPicFill (wxrect (WX.rect (WX.point 200 10) (WX.sz 10 200)))
+        in wxWithColor WX.red (upper `wxPicOver` left `wxPicOver` right)
+
+paddle :: Int -> WX.Rect
+paddle xpos = WX.rect (WX.Point (xpos - 25) 200) (WX.sz 50 10)
+
+gameBox = WX.sz 215 215
+
+-- The game screen: takes signals for the velocity of the
+-- ball and the current mouse position; outputs a picture
+-- of the game and a game-over event.
+pball :: SF (Double,WX.Point) (WXPicture,Event ())
+pball = proc (vel,mpos) -> do
+  rec xi <- integral -< xvel
+      yi <- integral -< yvel
+      let xpos = 30 + xi
+      let ypos = 30 + yi
+      let ballS = WX.rect (WX.point (round (xpos - 12.5)) (round (ypos - 12.5)))
+                          (WX.sz 25 25)
+      let ballPicS = wxWithColor WX.yellow $ wxPicFill $ wxellipse ballS
+      xbounce <- edge -< ((xpos > 175) || (xpos < 45))
+      ybounce <- edge -< ((ypos < 45) || hitPaddle)
+      let hitPaddle = WX.rectOverlaps ballS paddleS
+      xdir <- accumHold 1 -< xbounce `tag` negate
+      ydir <- accumHold 1 -< ybounce `tag` negate
+      let xvel = xdir * vel
+      let yvel = ydir * vel
+      let paddleS = paddle (WX.pointX mpos)
+      let paddlePicS = wxWithColor WX.green $ wxPicFill $ wxrect paddleS
+      gameOver <- edge -< ypos > 250
+      let gamePic = walls `wxPicOver` paddlePicS `wxPicOver` ballPicS `wxPicOver` bg
+  returnA -< (gamePic,gameOver)
+
+-- The game-over screen.
+death :: SF a (WXPicture,Event b)
+death = proc _ -> do
+  returnA -< (deathPic,noEvent)
+    where deathPic = wxwrite "Game Over!" (WX.Point 70 100)
+
+-- The game GUI: wrapper around the game-on and
+-- and game-over screens.
+pbgame :: WXGUI (Double,Event ()) (Event ())
+pbgame = wxHBox $ proc (vel,restart) -> do
+  rec let next = (gameOver `tag` death) `merge` (restart `tag` pball)
+      mpos <- wxmouse -< ()
+      (gamePic,gameOver) <- wxBoxSF (drSwitch pball) -< ((vel,mpos),next)
+  _ <- wxpicture (psize gameBox) -< ppic gamePic
+  returnA -< gameOver
+
+-- The game-control GUI: widgets for controlling
+-- the speed of the ball and restarting the game.
+pbcontrol :: WXGUI (Event ()) (Double,Event ())
+pbcontrol = wxVBox $ proc gameOver -> do
+  rec _ <- wxtext id -< (ttext ("Speed: " ++ (show vel))) 
+      v <- wxslider Vert 5 15 (sselection 10) -< id
+      let vel = v * 10
+      stopped <- wxBoxSF (hold False)
+        -< (playAgain `tag` False) `merge` (gameOver `tag` True)
+      playAgain <- wxbutton (btext "Play Again") -< benabled stopped
+  returnA -< (fromIntegral vel,playAgain)
+
+-- The top-level GUI: puts it all together.
+paddleBall :: WXGUI () ()
+paddleBall = wxHBox $ proc _ -> do
+  rec gameOver <- wxBox pbgame -< (vel,playAgain)
+      (vel,playAgain) <- wxBox pbcontrol -< gameOver
+  returnA -< ()
+
+main :: IO ()
+main = startGUI "PaddleBall" paddleBall
+ wxFruit.cabal view
@@ -0,0 +1,32 @@+name: wxFruit+version: 0.1+Cabal-Version:		>= 1.2+License: BSD3+License-file: LICENSE+Author: Antony Courtney, Bart Robinson, Paul Hudak+homepage: http://zoo.cs.yale.edu/classes/cs490/03-04b/bartholomew.robinson/+category: Reactivity, FRP+synopsis: An implementation of Fruit using wxHaskell.+description:+  This is an original version of wxFruit.+  .+  wxFruit isn't maintained by original authors, and Haskell.org. So, there is a few forked version of wxFruit now. One extension is shelarcy's YaPan ( http://sourceforge.net/project/showfiles.php?group_id=168626&package_id=199138 ). It added Menu and OpenGL support. And another one is Remi Turk's Juicy Fruit ( http://www.cs.uu.nl/wiki/pub/Afp0607/DomainSpecificLanguages/fruit.pdf ). So, I uploaded this original version first.++build-type: Simple+Flag splitBase+    Description: Choose the new smaller, split-up base package.+Library+    if flag(splitBase)+        build-depends: base >= 3, old-time, wx, wxcore, Yampa >= 0.9.1 && < 0.9.2+    else+        build-depends: base <  3,  wx, wxcore, Yampa >= 0.9.1 && < 0.9.2+  Exposed-modules: WXFruit+  Extensions: Arrows++Executable paddle+    if flag(splitBase)+        build-depends: base, wx, wxcore, Yampa >= 0.9.1 && < 0.9.2+    else+        build-depends: base, wx, wxcore, Yampa >= 0.9.1 && < 0.9.2+  Main-is: paddle.hs+  Extensions: Arrows