diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -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 diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -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/" ++) $ diff --git a/data/burning.ico b/data/burning.ico new file mode 100644 Binary files /dev/null and b/data/burning.ico differ diff --git a/data/explode.wav b/data/explode.wav new file mode 100644 Binary files /dev/null and b/data/explode.wav differ diff --git a/data/rock.ico b/data/rock.ico new file mode 100644 Binary files /dev/null and b/data/rock.ico differ diff --git a/data/ship.ico b/data/ship.ico new file mode 100644 Binary files /dev/null and b/data/ship.ico differ diff --git a/reactive-banana-wx.cabal b/reactive-banana-wx.cabal --- a/reactive-banana-wx.cabal +++ b/reactive-banana-wx.cabal @@ -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 diff --git a/src/Arithmetic.hs b/src/Arithmetic.hs new file mode 100644 --- /dev/null +++ b/src/Arithmetic.hs @@ -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 diff --git a/src/Asteroids.hs b/src/Asteroids.hs --- a/src/Asteroids.hs +++ b/src/Asteroids.hs @@ -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 diff --git a/src/CurrencyConverter.hs b/src/CurrencyConverter.hs --- a/src/CurrencyConverter.hs +++ b/src/CurrencyConverter.hs @@ -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) diff --git a/src/TicTacToe.hs b/src/TicTacToe.hs new file mode 100644 --- /dev/null +++ b/src/TicTacToe.hs @@ -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