lifter-0.1: src/Main.hs
module Main where
import Map
import Rules
import Paths_lifter
import Graphics.Gloss
import Graphics.Gloss.Interface.IO.Game
import Graphics.Gloss.Interface.IO.Simulate
import System.FilePath
import System.Directory
import Data.Array.IO
import System.Environment
import Debug.Trace
import Control.Monad
import Foreign.Marshal.Array hiding (newArray)
import Foreign.Storable
import qualified Data.ByteString as B
import Codec.Image.STB
import Data.Bitmap.Simple
data Opts = Opts { mapFile :: FilePath,
route :: Maybe FilePath,
displayRun :: Bool,
tracing :: Bool,
showEnd :: Bool,
displaySpeed :: Int,
mscale :: Float }
main = do ddir <- getDataDir
args <- getArgs
opts <- processArgs ddir args
(Opts (error "No map file") Nothing False False False 10 2)
imgs <- mkImgData
initSt' <- loadMap imgs (mapFile opts) (tracing opts)
let initSt = initSt' { iscale = mscale opts }
((wl,hl), (wh,hh)) <- getBounds (world initSt)
let max = ((wh - wl) + 1) * ((hh - hl) + 1)
case route opts of
Nothing ->
playIO (InWindow "Lambda Lifter" (800, 600) (10, 10)) (greyN 0.2)
30 -- set FPS
initSt
drawWorld
handleInput
stepWorld
Just r ->
do rinfo <- readFile r
if (displayRun opts)
then
simulateIO
(InWindow "Lambda Lifter" (800, 600) (10, 10)) (greyN 0.2)
(displaySpeed opts)
(initSt, take max rinfo)
(\ (s, _) -> drawWorld s)
stepSimulate
else
do endSt <- validate initSt (take max rinfo)
putStrLn $ "Score: " ++ show (score endSt)
when (won endSt) $ putStrLn "Mining complete"
when (dead endSt) $ putStrLn "Robot squashed"
when (showEnd opts) $ do m <- printMap (world endSt) (waterlevel endSt)
putStrLn m
where
processArgs d [] o = return o
processArgs d ("--route":r:rest) o
= processArgs d rest (o { route = Just r })
processArgs d ("--display":rest) o
= processArgs d rest (o { displayRun = True })
processArgs d ("--txt":rest) o
= processArgs d rest (o { showEnd = True })
processArgs d ("--speed":n:rest) o
= processArgs d rest (o { displaySpeed = read n })
processArgs d ("--scale":n:rest) o
= processArgs d rest (o { mscale = read n })
processArgs d ("--trace":rest) o
= processArgs d rest (o { tracing = True })
processArgs d (m:rest) o
= do ok <- doesFileExist m
if ok then processArgs d rest (o { mapFile = m } )
else processArgs d rest (o { mapFile = (d ++ "/maps/" ++ m) } )
blackPixel = [15,6,2,255]
brownPixel = [139,69,19,255]
lineA, lineB :: [Word8]
lineA = concat (take 8 (repeat (blackPixel ++ brownPixel)))
lineB = concat (take 8 (repeat (brownPixel ++ blackPixel)))
dirtData :: [Word8]
dirtData = concat (take 8 (repeat (lineA ++ lineB)))
dirtBMP = bitmapOfByteString 16 16 (B.pack dirtData) True
getBMPdata :: Bitmap Word8 -> IO Picture
getBMPdata img = withBitmap img $
\ (w, h) nchans pad ptr ->
do -- read the raw data
idata <- word8s (w * h * nchans) ptr []
-- rgba is reversed, so fix it
let idata' = swapOrder idata
-- upside down, so fix it...
let idata'' = invert (w * nchans) idata'
return (bmp idata'')
where word8s 0 ptr acc = return (reverse acc)
word8s n ptr acc = do i <- peek ptr
let ptr' = advancePtr ptr 1
word8s (n - 1) ptr' (i : acc)
bmp bdata = bitmapOfByteString 16 16 (B.pack bdata) True
swapOrder (a:b:g:r:rest) = r:g:b:a: (swapOrder rest)
swapOrder xs = xs
invert w dat = concat $ reverse (splitAt w dat)
splitAt n xs | n < length xs = take n xs : splitAt n (drop n xs)
| otherwise = [xs]
loadPic :: String -> IO Picture
loadPic p = do ddir <- getDataDir
imgIn <- loadImage (ddir ++ "/graphics/" ++ p ++ ".bmp")
case imgIn of
Left err ->fail err
Right img -> getBMPdata img
mkImgData = do brickBMP <- loadPic "bricks"
lambdaBMP <- loadPic "lambda"
rockBMP <- loadPic "rock"
lamrockBMP <- loadPic "lamrock"
playerBMP <- loadPic "miner"
bugBMP <- loadPic "bug"
liftBMP <- loadPic "lift"
razorBMP <- loadPic "razor"
beardBMP <- loadPic "beard"
trampolineBMP <- loadPic "goto"
targetBMP <- loadPic "target"
openliftBMP <- loadPic "openlift"
return (Imgs brickBMP dirtBMP lambdaBMP rockBMP lamrockBMP
playerBMP bugBMP
liftBMP openliftBMP razorBMP beardBMP trampolineBMP
targetBMP)
handleInput (EventKey (SpecialKey KeyUp) Down ms fs) s = return $ s { ymove = 1,
xmove = 0 }
handleInput (EventKey (SpecialKey KeyUp) Up ms fs) s = return $ s { ymove = 0 }
handleInput (EventKey (SpecialKey KeyDown) Down ms fs) s = return $ s { ymove = -1,
xmove = 0 }
handleInput (EventKey (SpecialKey KeyDown) Up ms fs) s = return $ s { ymove = 0 }
handleInput (EventKey (SpecialKey KeyLeft) Down ms fs) s = return $ s { xmove = -1,
ymove = 0 }
handleInput (EventKey (SpecialKey KeyLeft) Up ms fs) s = return $ s { xmove = 0 }
handleInput (EventKey (SpecialKey KeyRight) Down ms fs) s = return $ s { xmove = 1,
ymove = 0 }
handleInput (EventKey (SpecialKey KeyRight) Up ms fs) s = return $ s { xmove = 0 }
handleInput (EventKey (SpecialKey KeySpace) Up ms fs) s = return $ s { shave = True }
handleInput (EventKey (Char 'w') Up ms fs) s = return $ s { pause = True }
handleInput _ s = return $ s
drawWorld st = do ts <- getAssocs (world st)
let water = waterlevel st
let (x, y) = playerpos st
(ex, ey) = exitpos st
p = player (bitmaps st)
return $ Pictures [
Scale (iscale st) (iscale st) $
Pictures (p : -- centre on player
toPic st water x y (((ex, ey), mkExit) :
(filter (nearPos (iscale st) (x,y)) ts))),
winPic (won st),
losePic (dead st),
scorePic (score st)]
where mkExit | lambdas st == 0 = ExitOpen
| otherwise = Exit
exitOpen st = False
nearPos s (x, y) ((x', y'), _) = fromIntegral (abs (x - x')) < (40 / s) &&
fromIntegral (abs (y - y')) < (40 / s)
winPic False = Pictures []
winPic True = Translate (-250) 0 $ Color yellow $ Text "You win!"
losePic False = Pictures []
losePic True = Translate (-220) 0 $ Color (light red) $ Text "Ouch!!"
scorePic i = Translate (-380) 260 $ Scale 0.2 0.2 $
Color white $ Text ("Score: " ++ show i)
data ImgData = Imgs { bricks :: Picture,
dirt :: Picture,
lambda :: Picture,
rock :: Picture,
lamrock :: Picture,
player :: Picture,
bug :: Picture,
closedlift :: Picture,
openlift :: Picture,
razor :: Picture,
beard :: Picture,
trampoline :: Picture,
target :: Picture
}
toPic :: GameState ImgData -> Int -> Int -> Int -> [((Int, Int), Tile)] -> [Picture]
toPic st water xoff yoff world = map pic world
where pic ((x, y), t) = Translate (toEnum ((x-xoff) * 16))
(toEnum ((y-yoff) * 16)) $
if (y < water)
then Pictures [Color (makeColor8 0 0 255 128)
(Polygon [(-8,-8),(8,-8),(8,8),(-8,8)]), showPic t]
else showPic t
showPic Wall = bricks (bitmaps st)
showPic Dirt = dirt (bitmaps st)
showPic (Bug _ _) = bug (bitmaps st)
showPic Rock = rock (bitmaps st)
showPic Lambda = lambda (bitmaps st)
showPic LamRock = lamrock (bitmaps st)
showPic Exit = closedlift (bitmaps st)
showPic ExitOpen = openlift (bitmaps st)
showPic Razor = razor (bitmaps st)
showPic (Beard _) = beard (bitmaps st)
showPic (Trampoline _) = trampoline (bitmaps st)
showPic Target = target (bitmaps st)
showPic _ = Pictures []