wxcore-0.10.3: samples/contrib/Camels.hs
{--------------------------------------------------------------------------------
Camel game by Maarten Löfler (mloffler@cs.uu.nl) (adapted by Daan Leijen).
--------------------------------------------------------------------------------}
module Main where
import Graphics.UI.WX
import Graphics.UI.WXCore
{--------------------------------------------------------------------------------
The game
--------------------------------------------------------------------------------}
type Board = [Field]
data Field = Full Camel | Empty deriving Eq
data Camel = East | West deriving Eq
newBoard :: Int -> Board
newBoard x | even x = error "board size must be odd"
| x < 3 = error "board size must be at least 3"
| otherwise = let c = x `div` 2
in replicate c (Full East) ++ Empty : replicate c (Full West)
correct :: Board -> Bool
correct fs = let c = length fs `div` 2
in all (== Full West) (take c fs)
&& all (== Full East) (drop (c + 1) fs)
(|>) :: Int -> Field -> Board -> Board
(|>) _ _ [] = []
(|>) 0 f (_:bs) = f : bs
(|>) x f (b:bs) = b : (|>) (x - 1) f bs
moveAllowed :: Int -> Board -> Bool
moveAllowed x b | x < 0 = False
| x >= length b = False
| b !! x == Empty = False
| otherwise = case b !! x of Full East | x >= length b - 1 -> False
| b !! (x + 1) == Empty -> True
| b !! (x + 1) == Full East -> False
| x >= length b - 2 -> False
| b !! (x + 2) == Empty -> True
| otherwise -> False
Full West | x < 1 -> False
| b !! (x - 1) == Empty -> True
| b !! (x - 1) == Full West -> False
| x < 2 -> False
| b !! (x - 2) == Empty -> True
| otherwise -> False
Empty -> False
move :: Int -> Board -> Board
move x b = case b !! x of Full East -> case b !! (x + 1) of Empty -> (x |> Empty) . ((x + 1) |> Full East) $ b
_ -> (x |> Empty) . ((x + 2) |> Full East) $ b
Full West -> case b !! (x - 1) of Empty -> (x |> Empty) . ((x - 1) |> Full West) $ b
_ -> (x |> Empty) . ((x - 2) |> Full West) $ b
_ -> b
{--------------------------------------------------------------------------------
The GUI
--------------------------------------------------------------------------------}
main :: IO ()
main = start gui
gui :: IO ()
gui
= do desert <- varCreate (newBoard 3)
b <- bitmapCreateLoad "../bitmaps/desert.bmp" wxBITMAP_TYPE_BMP
f <- frame [ text := "Camels", on closing := do bitmapDelete b; propagateEvent ]
q <- button f [ text := "quit" , on command := close f ]
h <- button f [ text := "help" , on command := chelp f ]
a <- button f [ text := "about", on command := about f ]
p <- panel f [ clientSize := sz 320 240 ]
set p [ on resize := repaint p
, on click := klik p desert
, on paint := drawDesert desert b
, defaultButton := q
]
set f [ layout := column 0
[ fill $ widget p
, hfloatCentre $ margin 5 $ row 5 [widget q, widget h, widget a]
]]
return ()
drawDesert :: Var Board -> Bitmap () -> DC () -> Rect -> IO ()
drawDesert desert bmp dc (Rect x y w h) =
do drawBitmap dc bmp pointZero False []
for 0 (w `div` 234) (\i ->
for 0 (h `div` 87) (\j ->
drawBitmap dc bmp (pt (i * 234) (j * 87)) False []))
board <- varGet desert
let l = length board
s = min h $ w `div` l
xd = x + (w - l * s) `div` 2
yd = y + (h - s) `div` 2
for 0 (l - 1) (\i -> drawField dc (board !! i) (Rect (xd + i * s) yd s s))
return ()
for :: Int -> Int -> (Int -> IO ()) -> IO ()
for x y f = sequence_ $ map f [x..y]
drawField :: DC () -> Field -> Rect -> IO ()
drawField dc f r@(Rect x y w h) =
do set dc [brushKind := BrushSolid, brushColor := rgb 0x80 0x80 0x00]
case f of Full East -> do polygon dc (map (lin r) camel) []
polygon dc (map (lin r) saddle) [brushColor := red]
Full West -> do polygon dc (map (lin r . mirror) camel) []
polygon dc (map (lin r . mirror) saddle) [brushColor := blue]
_ -> return ()
camel :: [(Float, Float)]
camel = map (\(x, y) -> (x / 8, y / 8)) [(2, 2), (3, 3), (4, 2), (5, 3), (6, 2), (7, 3), (6, 3), (5, 5), (5, 7), (4, 7), (4, 5), (3, 5), (3, 7), (2, 7), (2, 4), (1, 6), (1, 4)]
saddle :: [(Float, Float)]
saddle = map (\(x, y) -> (x / 8, y / 8)) [(4, 2), (5, 3), (4, 4), (3, 3)]
mirror :: (Float, Float) -> (Float, Float)
mirror (x, y) = (1 - x, y)
lin :: Rect -> (Float, Float) -> Point
lin (Rect x y w h) (px, py) = let nx = floor $ (fromInteger . toInteger) w * px
ny = floor $ (fromInteger . toInteger) h * py
in Point (x + nx) (y + ny)
klik :: Panel () -> Var Board -> Point -> IO ()
klik pan desert (Point x y) =
do board <- varGet desert
(Size w h) <- get pan clientSize
let l = length board
s = min h $ w `div` l
xd = (w - l * s) `div` 2
yd = (h - s) `div` 2
i = (x - xd) `div` s
varUpdate desert (if moveAllowed i board then move i else id)
newboard <- varGet desert
repaint pan
eind pan desert newboard
return ()
eind :: Panel () -> Var Board -> Board -> IO ()
eind pan desert board
| any (flip moveAllowed board) [0 .. length board - 1] = return ()
| correct board = do infoDialog pan "Level up" "Congratulations! You succeeded."
varUpdate desert (const $ newBoard $ length board + 2)
repaint pan
| otherwise = do infoDialog pan "Level restart" "There are no more possible moves..."
varUpdate desert (const $ newBoard $ max 3 $ length board)
repaint pan
about :: Window a -> IO ()
about w
= infoDialog w "About Camels" "Camels\n\nby Maarten Löfler\nmloffler@cs.uu.nl\n\nCamels was written using wxHaskell"
chelp :: Window a -> IO ()
chelp w
= infoDialog w "Camels Help"
( "How to play Camels\n\n"
++ "The object of this puzzle is to move all the east looking camels to the eastern\n"
++ "end of the desert, and all the west looking camels to the west of the desert.\n"
++ "East looking camels can only move east, and west looking camels can only move\n"
++ "west. A camel can move one square forward (if that square is empty), or it can\n"
++ "jump over another camel if it is looking the OTHER way.\n\n"
++ "Once you succeed, you will advance to a higher level with more camels.\n\n"
++ "Good luck!\n"
)