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 []