reactive-banana-wx 0.4.1.1 → 0.4.2.0

raw patch · 11 files changed

+273/−59 lines, 11 filesdep +arraydep +containersdep +executable-pathdep −directorydep ~basedep ~reactive-bananasetup-changednew-component:exe:Arithmeticnew-component:exe:TicTacToebinary-added

Dependencies added: array, containers, executable-path, filepath, process

Dependencies removed: directory

Dependency ranges changed: base, reactive-banana

Files

Makefile +3/−36
Setup.hs +4/−2
data/burning.ico binary
data/explode.wav binary
data/rock.ico binary
data/ship.ico binary
reactive-banana-wx.cabal +21/−5
src/Arithmetic.hs +49/−0
src/Asteroids.hs +17/−11
src/CurrencyConverter.hs +9/−5
src/TicTacToe.hs +170/−0

Makefile view

@@ -1,38 +1,5 @@-.PHONY: all clean open--APPS=Asteroids Counter CRUD CurrencyConverter NetMonitor TwoCounters Wave-OBJ=dist/build-COMPILE=ghc --make -i$(OBJ) -L/usr/lib -L$(OBJ) -isrc -i../reactive-banana/src--all: $(APPS)--Asteroids : src/Asteroids.hs src/Reactive/Banana/WX.hs-	$(COMPILE) -o $@ $< -outputdir $(OBJ)/$@.tmp/-	macosx-app $@--Counter : src/Counter.hs src/Reactive/Banana/WX.hs-	$(COMPILE) -o $@ $< -outputdir $(OBJ)/$@.tmp/-	macosx-app $@--NetMonitor : src/NetMonitor.hs src/Reactive/Banana/WX.hs-	$(COMPILE) -o $@ $< -outputdir $(OBJ)/$@.tmp/-	macosx-app $@--CRUD : src/CRUD.hs src/Reactive/Banana/WX.hs-	$(COMPILE) -o $@ $< -outputdir $(OBJ)/$@.tmp/-	macosx-app $@--CurrencyConverter : src/CurrencyConverter.hs src/Reactive/Banana/WX.hs-	$(COMPILE) -o $@ $< -outputdir $(OBJ)/$@.tmp/-	macosx-app $@+.PHONY: all -TwoCounters : src/TwoCounters.hs src/Reactive/Banana/WX.hs-	$(COMPILE) -o $@ $< -outputdir $(OBJ)/$@.tmp/-	macosx-app $@-		-Wave : src/Wave.hs src/Reactive/Banana/WX.hs-	$(COMPILE) -o $@ $< -outputdir $(OBJ)/$@.tmp/-	macosx-app $@+all:+	cabal configure && cabal build --ghc-options=-L/usr/lib -clean:-	rm -rf $(APPS) $(OBJ)/*.o $(OBJ)/*.hi *.app *.exe *.manifest

Setup.hs view

@@ -14,12 +14,14 @@ guiApps = [MacApp "Asteroids"                   Nothing                   Nothing -- Build a default Info.plist for the icon.-                  files -- No other resources.+                  files   -- bitmaps and .wav                   [] -- No other binaries.                   DoNotChase -- Try changing to ChaseWithDefaults           ] ++ apps -apps = map app $ words "Counter CurrencyConverter TwoCounters Wave"+apps = map app $+    words "Arithmetic Counter CurrencyConverter CRUD"+    ++ words "NetMonitor TicTacToe TwoCounters Wave" app name = MacApp name Nothing Nothing [] [] DoNotChase  files = map ("data/" ++) $

+ data/burning.ico view

binary file changed (absent → 9650 bytes)

+ data/explode.wav view

binary file changed (absent → 23788 bytes)

+ data/rock.ico view

binary file changed (absent → 6770 bytes)

+ data/ship.ico view

binary file changed (absent → 3738 bytes)

reactive-banana-wx.cabal view

@@ -1,5 +1,5 @@ Name:                reactive-banana-wx-Version:             0.4.1.1+Version:             0.4.2.0 Synopsis:            Examples for the reactive-banana library, using wxHaskell. Description:     This library provides some GUI examples for the @reactive-banana@ library,@@ -20,12 +20,14 @@ Build-type:          Custom Extra-source-files:  Makefile +data-dir:            data+data-files:          *.ico, *.wav+ Library     hs-source-dirs:  src-    build-depends:   base >= 4.2 && < 4.4,-                     cabal-macosx == 0.1.*, random == 1.0.*,-                     directory == 1.1.*,-                     reactive-banana >= 0.4.1.0 && < 0.5,+    build-depends:   base >= 4.3 && < 5,+                     cabal-macosx == 0.1.*,+                     reactive-banana >= 0.4.2.0 && < 0.5,                      wx==0.12.*, wxcore==0.12.*     extensions:      ExistentialQuantification     exposed-modules: Reactive.Banana.WX@@ -35,8 +37,15 @@     location:        git://github.com/HeinrichApfelmus/reactive-banana.git     subdir:          reactive-banana-wx +Executable Arithmetic+    hs-source-dirs:  src+    main-is:         Arithmetic.hs+ Executable Asteroids     hs-source-dirs:  src+    build-depends:   random == 1.0.*,+                     executable-path == 0.0.*, filepath == 1.2.*+    other-modules:   Paths_reactive_banana_wx     main-is:         Asteroids.hs  Executable Counter@@ -49,11 +58,18 @@  Executable CRUD     hs-source-dirs:  src+    build-depends:   containers == 0.4.*     main-is:         CRUD.hs  Executable NetMonitor     hs-source-dirs:  src+    build-depends:   process == 1.0.*     main-is:         NetMonitor.hs++Executable TicTacToe+    hs-source-dirs:  src+    build-depends:   array == 0.3.*+    main-is:         TicTacToe.hs  Executable TwoCounters     hs-source-dirs:  src

+ src/Arithmetic.hs view

@@ -0,0 +1,49 @@+{-----------------------------------------------------------------------------+    reactive-banana-wx+    +    Example: Very simple arithmetic+------------------------------------------------------------------------------}+import Data.Maybe+import Graphics.UI.WX hiding (Event)+import Reactive.Banana+import Reactive.Banana.WX++{-----------------------------------------------------------------------------+    Main+------------------------------------------------------------------------------}+main = start $ do+    f         <- frame    [text := "Arithmetic"]+    calculate <- button f [text := "="]+    input1    <- entry f  [processEnter := True]+    input2    <- entry f  [processEnter := True]+    output    <- staticText f [ size := sz 40 20 ]+    +    set f [layout := margin 10 $ row 10 $+            [widget input1, label "+", widget input2+            , widget calculate, widget output]]++    network <- compile $ do+        -- TODO: Maybe include real-time updates? (see CurrencyConverter.hs)+        eenter1  <- event0 input1    command+        eenter2  <- event0 input2    command+        ebutton  <- event0 calculate command+        +        binput1  <- behavior input1 text+        binput2  <- behavior input2 text+        +        let+            ecalculate :: Event ()+            ecalculate = ebutton `union` eenter1 `union` eenter2+            +            result :: Discrete (Maybe Int)+            result = stepperD Nothing $+                (f <$> binput1 <*> binput2) <@ ecalculate+                where+                f x y = liftA2 (+) (readNumber x) (readNumber y)+            +            readNumber s = listToMaybe [x | (x,"") <- reads s]    +            showNumber   = maybe "--" show+    +        sink output [text :== showNumber <$> result]+    +    actuate network

src/Asteroids.hs view

@@ -8,10 +8,15 @@ import Graphics.UI.WXCore as WXCore import Reactive.Banana import Reactive.Banana.WX-import System.Directory   (getCurrentDirectory, setCurrentDirectory) import System.Random--- import Paths_wxAsteroids  (getDataDir) +-- boring path stuff+import System.Environment.Executable+import System.FilePath+import System.Info+import System.IO.Unsafe+import qualified Paths_reactive_banana_wx as Paths (getDataDir)+ {-----------------------------------------------------------------------------     Main ------------------------------------------------------------------------------}@@ -25,20 +30,21 @@ chance   = 0.1  rock, burning, ship :: Bitmap ()-rock    = bitmap "data/rock.ico"-burning = bitmap "data/burning.ico"-ship    = bitmap "data/ship.ico"+rock    = bitmap $ dataDir </> "rock.ico"+burning = bitmap $ dataDir </> "burning.ico"+ship    = bitmap $ dataDir </> "ship.ico"  explode :: WXCore.Sound ()-explode = sound  "data/explode.wav" +explode = sound $ dataDir </> "explode.wav"  -getDataDir = (++ "/data") <$> getCurrentDirectory+getDataDir+    | os == "darwin" =+        fmap (\x -> takeDirectory x </> ".." </> "Resources") getExecutablePath +    | otherwise      = Paths.getDataDir+dataDir = unsafePerformIO $ getDataDir  main :: IO ()-main = -    -- dataDirectory <- getDataDir-    -- setCurrentDirectory dataDirectory -    start asteroids+main = start asteroids  {-----------------------------------------------------------------------------     Game Logic

src/CurrencyConverter.hs view

@@ -7,6 +7,7 @@ import Data.Bits import Data.Maybe import Graphics.UI.WX hiding (Event)+import qualified Graphics.UI.WX.Events import Graphics.UI.WXCore hiding (Event) import Reactive.Banana import Reactive.Banana.WX@@ -25,7 +26,7 @@             column 10 [                 grid 10 10 [[label "Dollar:", widget dollar],                             [label "Euro:"  , widget euro  ]]-            , label "Press enter to convert"+            , label "Amounts update while typing."             ]]      network <- compile $ mdo        @@ -55,11 +56,14 @@ reactimateTextEntry entry input = do     sink entry [ text :== input ] -    -- FIXME: How to do real-time updates?-    -- The  keyboard  event always lags one character behind.-    -- Where is wxEVT_COMMAND_TEXT_UPDATED in wxHaskell?-    e <- event0   entry command+    -- Real-time text updates.+    -- Should be  wxEVT_COMMAND_TEXT_UPDATED  , but that's misisng from wxHaskell.+    e <- event1   entry keyboardUp     b <- behavior entry text     return $ b <@ e +-- observe "key up" events (many thanks to Abu Alam)+-- this should probably be in the wxHaskell library+keyboardUp  :: Graphics.UI.WX.Events.Event (Window a) (EventKey -> IO ())+keyboardUp  = newEvent "keyboardUp" windowGetOnKeyUp (windowOnKeyUp)

+ src/TicTacToe.hs view

@@ -0,0 +1,170 @@+{-----------------------------------------------------------------------------
+    reactive-banana-wx
+    
+    Example: A version of TicTacToe with silly interface elements
+    Author:  Gideon Sireling
+------------------------------------------------------------------------------}
+import Control.Monad
+import Data.Array
+import Data.List hiding (union)
+import Data.Maybe
+
+import Graphics.UI.WX hiding (Event)
+import Graphics.UI.WXCore hiding (Event)
+
+import Reactive.Banana
+import Reactive.Banana.WX
+
+{-----------------------------------------------------------------------------
+    User Interface
+------------------------------------------------------------------------------}
+
+main = start $ do
+    -- create the main window
+    window <- frame [text := "OX"]
+    label <- staticText window [text := "Move: X"]
+        -- overwritten by FRP, here to ensure correct positioning
+    btns <- replicateM 3 $ button window [size := sz 40 40]
+    radios <- replicateM 3 $ radioBox window Vertical ["", "?"] []
+    checks <- replicateM 3 $ checkBox window [text := "  "]
+        -- reserve space for X/O in label
+    
+    set window [layout := column 5 [grid 1 1
+                    [map widget btns, map widget radios, map widget checks]
+                    , floatCenter $ widget label]]
+
+    network <- compile $ do
+        -- convert WxHaskell events to FRP events
+        let event0s widgets event = forM widgets $ \x -> event0 x event
+        events <- liftM concat $ sequence
+            [event0s btns command, event0s radios select, event0s checks command]
+        
+        let
+            moves :: Event (State -> State)
+            moves = foldl1 union $ zipWith (\e s -> play s <$ e) events
+                    [(x,y) | y <- [1..3], x <- [1..3]]
+                    where play square (game, _) = move game square
+            
+            state :: Discrete State
+            state = accumD (newGame, Nothing) moves
+            
+            player :: Discrete String
+            player = (\(Game player _, _) -> show player) <$> state
+            
+            tokens :: [Discrete String]
+            tokens = map (\e -> stepperD "" (player <@ e)) events
+        
+        -- wire up the widget event handlers
+        zipWithM_ (\b e -> sink b [text :== e, enabled :== null <$> e])
+                  (map objectCast btns
+                  ++ map objectCast radios
+                  ++ map objectCast checks :: [Control ()])
+                  tokens
+        
+        sink label [text :== ("Move: " ++) <$> player]
+        
+        -- end game event handler
+        reactimate $ (end window . fromJust) <$>
+            filterE isJust (changes $ snd <$> state)
+    
+    actuate network
+
+end :: Frame () -> Token -> IO ()
+end window result = do
+    infoDialog window "" $ case result of
+                              X -> "X won!"
+                              O -> "O won!"
+                              None -> "Draw!"
+    close window
+
+{-----------------------------------------------------------------------------
+    Game Logic
+------------------------------------------------------------------------------}
+type State = (Game, Maybe Token)
+
+data Token = None | X | O
+    deriving Eq
+
+-- |The coordinates of a square.
+type Square = (Int,Int)
+
+-- |A noughts and crosses board.
+type Board = Array Square Token
+
+-- |Returns an empty 'Board'.
+newBoard :: Board
+newBoard = listArray ((1,1),(3,3)) (repeat None)
+
+-- |Puts a 'Token' in a 'Square'.
+setSquare :: Board -> Square -> Token -> Board
+setSquare board square token =
+    if (board ! square) /= None
+    then error $ "square " ++ show square ++ " is not empty"
+    else board // [(square, token)]
+
+-- |Determine if the 'Board' is in an end state.
+--  Returns 'Just' 'Token' if the game has been won,
+-- 'Just' 'None' for a draw, otherwise 'Nothing'.
+endGame :: Board -> Maybe Token
+endGame board
+    | Just X `elem` maybeWins = Just X
+    | Just O `elem` maybeWins = Just O
+    | None `notElem` elems board = Just None
+    | otherwise = Nothing
+
+    where rows :: [[Square]]
+          rows = let i = [1..3]
+                 in [[(x,y) | y <- i] | x <- i] ++ -- rows
+                    [[(y,x) | y <- i] | x <- i] ++ -- coloumns
+                    [[(x,x) | x <- i], [(x,4-x) | x <- i]] -- diagonals
+
+          rows2tokens :: [[Token]]
+          rows2tokens = map (map (board !)) rows
+
+          isWin :: [Token] -> Maybe Token
+          isWin tokens
+              | all (==X) tokens = Just X
+              | all (==O) tokens = Just O
+              | otherwise = Nothing
+
+          maybeWins :: [Maybe Token]
+          maybeWins = map isWin rows2tokens
+
+-- |The state of a game, i.e. the player who's turn it is, and the current board.
+data Game = Game Token Board
+
+newGame :: Game
+newGame = Game X newBoard
+
+-- |Puts the player's token on the specified square.
+-- Returns 'Just' 'Token' if the game has been won,
+-- 'Just' 'None' for a draw, otherwise 'Nothing'.
+move :: Game -> Square -> (Game, Maybe Token)
+move (Game player board) square =
+    let board' = setSquare board square player
+        player' = case player of {X -> O; O -> X}
+    in (Game player' board', endGame board')
+
+{-----------------------------------------------------------------------------
+    Show instances
+------------------------------------------------------------------------------}
+outersperse :: a -> [a] -> [a]
+outersperse x ys = x : intersperse x ys ++ [x]
+
+instance Show Token where
+    show X = "X"
+    show O = "O"
+    show None = " "
+    showList tokens = showString $ outersperse '|' $ concatMap show tokens
+
+-- Board cannot be declared an instance of Show,
+-- as this would overlap with the existing instance for Array.
+showBoard :: Board -> String
+showBoard board =
+    let border = " +-+-+-+"
+        i = [1..3]
+        showRow x = show x ++ show [board ! (y,x) | y <- i]
+    in intercalate "\n" $ "  1 2 3" : outersperse border (map showRow i)
+
+instance Show Game where
+    show (Game player board) = showBoard board ++ "\n\nTurn: " ++ show player