Commit 90c87bde7eef6358f6de40c38ad47554cd051ffd - animated-dangerzone-sdl

Adding existing components to git Getty Ritter 10 years ago

12 changed file(s) with 472 addition(s) and 0 deletion(s). Collapse all Expand all

-0

LICENSE less more

(New empty file)

-0

Setup.hs less more

	1	import Distribution.Simple
	2	main = defaultMain

+43

-0

animated-dangerzone-sdl.cabal less more

	1	-- Initial animated-dangerzone-sdl.cabal generated by cabal init. For
	2	-- further documentation, see http://haskell.org/cabal/users-guide/
	3
	4	name: animated-dangerzone-sdl
	5	version: 0.1.0.0
	6	synopsis: SDL-based client for ADz
	7	-- description:
	8	-- license:
	9	license-file: LICENSE
	10	author: Getty D. Ritter
	11	maintainer: Getty D. Ritter
	12	copyright: (c) 2013
	13	category: Game
	14	build-type: Simple
	15	cabal-version: >=1.8
	16
	17	executable ad-sdlclient
	18	main-is: SDLClient.hs
	19	build-depends: base ==4.6.*,
	20	array ==0.4.*,
	21	SDL ==0.6.*,
	22	aeson ==0.6.*,
	23	bytestring ==0.10.*,
	24	containers ==0.5.*,
	25	animated-dangerzone ==0.1.*,
	26	random,
	27	stb-image,
	28	zip-archive,
	29	bitmap
	30	hs-source-dirs: src
	31
	32	executable make-texture
	33	main-is: MakeTexture.hs
	34	build-depends: base ==4.6.*,
	35	bytestring,
	36	containers ==0.5.*,
	37	animated-dangerzone ==0.1.*,
	38	stb-image,
	39	SDL,
	40	array,
	41	zip-archive,
	42	bitmap
	43	hs-source-dirs: src

+40

-0

src/MakeTexture.hs less more

	1	module Main where
	2
	3	import Codec.Archive.Zip
	4	import qualified Data.ByteString.Char8 as BS8
	5	import qualified Data.ByteString.Lazy as BSL
	6	import qualified Data.ByteString.Lazy.Char8 as BSL8
	7	import System.Environment (getArgs)
	8
	9	import SDLClient.SpriteSheet
	10
	11	usage :: String
	12	usage = unlines [ "USAGE: make-texture [name] [width] [height] [type] [spritesheet] "
	13	, " name : string"
	14	, " width : int"
	15	, " height : int"
	16	, " type : basic \| fence \| blob"
	17	, " spritesheet : png"
	18	]
	19
	20	main :: IO ()
	21	main = do
	22	args <- getArgs
	23	case args of
	24	(name:width:height:typ:sheet:_) -> do
	25	imgContents <- BSL.readFile sheet
	26	let desc = SpriteDescription
	27	{ sdSize = (read width, read height)
	28	, sdName = (BS8.pack name)
	29	, sdType = case typ of
	30	"basic" -> BasicSprite
	31	"fence" -> FenceSprite
	32	"blob" -> BlobSprite
	33	_ -> error "unknown sprite type"
	34	}
	35	let meta = toEntry "texture.hs" 0 (BSL8.pack (show desc))
	36	let png = toEntry "sprites.png" 0 imgContents
	37	let archive = meta `addEntryToArchive`
	38	(png `addEntryToArchive` emptyArchive)
	39	BSL.writeFile (name ++ ".texture") (fromArchive archive)
	40	_ -> putStrLn usage

-0

src/SDLClient/Blob.hs less more

	1	module SDLClient.Blob where
	2
	3	data SpriteType
	4	\| OneSprite
	5	\| RugSprite
	6	\| FenceSprite
	7	\| BlobSprite
	8	deriving (Eq,Show)

+15

-0

src/SDLClient/Draw.hs less more

	1	module SDLClient.Draw where
	2
	3	import SDLClient.SpriteSheet
	4	import AnimatedDangerzone.Types
	5
	6	import Data.Array
	7	import qualified Data.Map as Map
	8	import qualified Graphics.UI.SDL as SDL
	9
	10	drawWorld :: World -> IO ()
	11	drawWorld world = do
	12	let playerLocs = map () (elems (w .^ worldPlayers))
	13	mapM_ go (Map.fromList (w .^ worldBlocks))
	14	where go ((x, y), b)
	15	\| Map.member (x, y) (w .^ w)

+331

-0

src/SDLClient/SpriteSheet.hs less more

	1	{-# LANGUAGE RecordWildCards #-}
	2	{-# LANGUAGE OverloadedStrings #-}
	3
	4	module SDLClient.SpriteSheet
	5	( SpriteSheet(..)
	6	, SpriteDescription(..)
	7	, SpriteSheetType(..)
	8	, loadSpriteSheet
	9	, drawMap
	10	) where
	11
	12	import Codec.Archive.Zip
	13	import Codec.Image.STB (decodeImage)
	14	import Control.Monad (mzero)
	15	import Data.Array
	16	import Data.Bitmap (withBitmap)
	17	import qualified Data.ByteString as BS
	18	import Data.ByteString.Lazy.Char8 (unpack)
	19	import qualified Data.ByteString.Lazy as BSL
	20	import qualified Data.Map as M
	21	import Data.Word (Word32)
	22	import qualified Graphics.UI.SDL as SDL
	23
	24	data SpriteSheet = SpriteSheet
	25	{ drawSprite :: Neighborhood Adj -> SDL.Surface -> (Int, Int) -> IO ()
	26	}
	27
	28	data SpriteSheetType
	29	= BasicSprite -- Where adjacent tiles don't matter
	30	\| FenceSprite -- Where the Von Neumann neighborhood determines the sprite
	31	\| BlobSprite -- Where the Moore neighborhood determines the sprite
	32	deriving (Eq,Show,Read)
	33
	34	type Pt = (Int, Int)
	35
	36	-- A Moore neighborhood, i.e. a tile and everything surrounding it
	37	newtype Neighborhood a = N (a,a,a
	38	,a,a,a
	39	,a,a,a) deriving (Eq,Show)
	40
	41	instance Functor Neighborhood where
	42	fmap f (N (a,b,c,d,e,g,h,i,j)) =
	43	N (f a, f b, f c, f d, f e, f g, f h, f i, f j)
	44
	45	-- An adjacent tile is either the Same or Different
	46	-- In the neighborhoods we create, the center will always
	47	-- be S, because it's the same as itself
	48	data Adj = S \| D deriving (Eq,Show)
	49
	50	-- XXX: animated sprites as well
	51	data SpriteDescription = SpriteDescription
	52	{ sdName :: BS.ByteString
	53	, sdSize :: (Int, Int)
	54	, sdType :: SpriteSheetType
	55	} deriving (Eq,Show,Read)
	56
	57	mkSpriteSheet :: (Int, Int) -> (Int, Int) -> (Neighborhood Adj -> Int) -> SDL.Surface -> IO SpriteSheet
	58	mkSpriteSheet (sW, sH) (iW, iH) getIdx sprites = do
	59	let drawSprite hood screen (xP, yP) = do
	60	let n = getIdx hood
	61	let (u, v) = (rem n iW * sW, div n iW * sH)
	62	let (x, y) = (xP * sW, yP * sH)
	63	SDL.blitSurface sprites (Just (SDL.Rect u v sW sH))
	64	screen (Just (SDL.Rect x y sW sH))
	65	return ()
	66	return SpriteSheet { .. }
	67
	68	parseImg :: String -> BSL.ByteString -> IO SDL.Surface
	69	parseImg errmsg bs = do
	70	result <- decodeImage (BSL.toStrict bs)
	71	case result of
	72	Right img -> withBitmap img (\(width, height) chn pad ptr -> do
	73	let pitch = (width * chn) + pad
	74	let (r,g,b,a) = components chn
	75	SDL.createRGBSurfaceFrom ptr width height (8 * chn) pitch r g b a)
	76	Left err -> error (errmsg ++ ": " ++ err)
	77
	78	components :: Int -> (Word32, Word32, Word32, Word32)
	79	components 1 = (0xFF000000,0xFF000000,0xFF000000,0x00000000)
	80	components 2 = (0x00FF0000,0x00FF0000,0x00FF0000,0xFF000000)
	81	components 3 = (0x000000FF,0x0000FF00,0x00FF0000,0x00000000)
	82	components 4 = (0x000000FF,0x0000FF00,0x00FF0000,0xFF000000)
	83
	84
	85	loadSpriteSheet :: FilePath -> IO SpriteSheet
	86	loadSpriteSheet path = do
	87	rawArchive <- toArchive `fmap` BSL.readFile path
	88	let Just meta = findEntryByPath "texture.hs" rawArchive
	89	let Just png = findEntryByPath "sprites.png" rawArchive
	90	let SpriteDescription { .. } = read (unpack (fromEntry meta))
	91	let errmsg = "Error loading " ++ path ++ ": "
	92	surface <- parseImg errmsg (fromEntry png)
	93	let sz = case sdType of
	94	BasicSprite -> (1,1)
	95	FenceSprite -> (4,4)
	96	BlobSprite -> (10,5)
	97	let getIds = case sdType of
	98	BasicSprite -> const 0
	99	FenceSprite -> fenceLookup
	100	BlobSprite -> blobLookup
	101	mkSpriteSheet sdSize sz getIds surface
	102
	103	center :: Neighborhood a -> a
	104	center (N (_,_,_,_,x,_,_,_,_)) = x
	105
	106	lkp :: Array Pt a -> Pt -> (Maybe a)
	107	lkp arr pt
	108	\| inRange (bounds arr) pt = Just (arr ! pt)
	109	\| otherwise = Nothing
	110
	111	getNeighborhood :: Array Pt a -> Pt -> Neighborhood (Maybe a)
	112	getNeighborhood arr (x, y) = N
	113	( go (x-1, y-1), go (x , y-1), go (x+1, y-1)
	114	, go (x-1, y ), go (x , y ), go (x+1, y )
	115	, go (x-1, y+1), go (x , y+1), go (x+1, y+1)
	116	) where go = lkp arr
	117
	118	getMapNeighborhood :: M.Map Pt a -> Pt -> Neighborhood (Maybe a)
	119	getMapNeighborhood mp (x, y) = N
	120	( go (x-1, y-1), go (x , y-1), go (x+1, y-1)
	121	, go (x-1, y ), go (x , y ), go (x+1, y )
	122	, go (x-1, y+1), go (x , y+1), go (x+1, y+1)
	123	) where go pt = M.lookup pt mp
	124
	125	toAdj :: (Eq a) => Neighborhood (Maybe a) -> Neighborhood Adj
	126	toAdj (N (a,b,c,d,Just e,f,g,h,i)) =
	127	N (go a, go b, go c, go d, S, go f, go g, go h, go i)
	128	where go (Just x) \| x == e = S
	129	\| otherwise = D
	130	go Nothing = S
	131
	132	drawMap :: (Eq a) => (a -> SpriteSheet) -> M.Map Pt a
	133	-> SDL.Surface -> IO ()
	134	drawMap spriteFor map surf = mapM_ go (M.assocs map)
	135	where go ((x, y), b) = drawSprite sheet adj surf (x, y)
	136	where hood = getMapNeighborhood map (x, y)
	137	adj = toAdj hood
	138	sheet = spriteFor b
	139
	140	fenceLookup :: Neighborhood Adj -> Int
	141	fenceLookup (N (_,D,_
	142	,D,_,D
	143	,_,S,_)) = 0
	144	fenceLookup (N (_,D,_
	145	,D,_,S
	146	,_,S,_)) = 1
	147	fenceLookup (N (_,D,_
	148	,S,_,S
	149	,_,S,_)) = 2
	150	fenceLookup (N (_,D,_
	151	,S,_,D
	152	,_,S,_)) = 3
	153	fenceLookup (N (_,S,_
	154	,D,_,D
	155	,_,S,_)) = 4
	156	fenceLookup (N (_,S,_
	157	,D,_,S
	158	,_,S,_)) = 5
	159	fenceLookup (N (_,S,_
	160	,S,_,S
	161	,_,S,_)) = 6
	162	fenceLookup (N (_,S,_
	163	,S,_,D
	164	,_,S,_)) = 7
	165	fenceLookup (N (_,S,_
	166	,D,_,D
	167	,_,D,_)) = 8
	168	fenceLookup (N (_,S,_
	169	,D,_,S
	170	,_,D,_)) = 9
	171	fenceLookup (N (_,S,_
	172	,S,_,S
	173	,_,D,_)) = 10
	174	fenceLookup (N (_,S,_
	175	,S,_,D
	176	,_,D,_)) = 11
	177	fenceLookup (N (_,D,_
	178	,D,_,D
	179	,_,D,_)) = 12
	180	fenceLookup (N (_,D,_
	181	,D,_,S
	182	,_,D,_)) = 13
	183	fenceLookup (N (_,D,_
	184	,S,_,S
	185	,_,D,_)) = 14
	186	fenceLookup (N (_,D,_
	187	,S,_,D
	188	,_,D,_)) = 15
	189
	190	blobLookup :: Neighborhood Adj -> Int
	191	blobLookup (N (_,D,_
	192	,D,_,D
	193	,_,S,_)) = 0
	194	blobLookup (N (_,D,_
	195	,D,_,S
	196	,_,S,S)) = 1
	197	blobLookup (N (_,D,_
	198	,S,_,S
	199	,S,S,S)) = 2
	200	blobLookup (N (_,D,_
	201	,S,_,D
	202	,S,S,_)) = 3
	203	blobLookup (N (_,D,_
	204	,D,_,S
	205	,_,S,D)) = 4
	206	blobLookup (N (_,D,_
	207	,S,_,S
	208	,D,S,D)) = 5
	209	blobLookup (N (_,D,_
	210	,S,_,D
	211	,D,S,_)) = 6
	212	blobLookup (N (S,S,S
	213	,S,_,S
	214	,S,S,D)) = 7
	215	blobLookup (N (S,S,S
	216	,S,_,S
	217	,D,S,D)) = 8
	218	blobLookup (N (S,S,S
	219	,S,_,S
	220	,D,S,S)) = 9
	221	blobLookup (N (_,S,_
	222	,D,_,D
	223	,_,S,_)) = 10
	224	blobLookup (N (_,S,S
	225	,D,_,S
	226	,_,S,S)) = 11
	227	blobLookup (N (S,S,S
	228	,S,_,S
	229	,S,S,S)) = 12
	230	blobLookup (N (S,S,_
	231	,S,_,D
	232	,S,S,_)) = 13
	233	blobLookup (N (_,S,D
	234	,D,_,S
	235	,_,S,D)) = 14
	236	blobLookup (N (_,D,_
	237	,D,_,D
	238	,_,D,_)) = 15
	239	blobLookup (N (D,S,_
	240	,S,_,D
	241	,D,S,_)) = 16
	242	blobLookup (N (S,S,D
	243	,S,_,S
	244	,S,S,D)) = 17
	245	blobLookup (N (D,S,D
	246	,S,_,S
	247	,D,S,D)) = 18
	248	blobLookup (N (D,S,S
	249	,S,_,S
	250	,D,S,S)) = 19
	251	blobLookup (N (_,S,_
	252	,D,_,D
	253	,_,D,_)) = 20
	254	blobLookup (N (_,S,S
	255	,D,_,S
	256	,_,D,_)) = 21
	257	blobLookup (N (S,S,S
	258	,S,_,S
	259	,_,D,_)) = 22
	260	blobLookup (N (S,S,_
	261	,S,_,D
	262	,_,D,_)) = 23
	263	blobLookup (N (_,S,D
	264	,D,_,S
	265	,_,D,_)) = 24
	266	blobLookup (N (D,S,D
	267	,S,_,S
	268	,_,D,_)) = 25
	269	blobLookup (N (D,S,_
	270	,S,_,D
	271	,_,D,_)) = 26
	272	blobLookup (N (S,S,D
	273	,S,_,S
	274	,S,S,S)) = 27
	275	blobLookup (N (D,S,D
	276	,S,_,S
	277	,S,S,S)) = 28
	278	blobLookup (N (D,S,S
	279	,S,_,S
	280	,S,S,S)) = 29
	281	blobLookup (N (_,D,_
	282	,D,_,S
	283	,_,D,_)) = 31
	284	blobLookup (N (_,D,_
	285	,S,_,S
	286	,_,D,_)) = 32
	287	blobLookup (N (_,D,_
	288	,S,_,D
	289	,_,D,_)) = 33
	290	blobLookup (N (_,D,_
	291	,S,_,S
	292	,S,S,D)) = 34
	293	blobLookup (N (S,S,_
	294	,S,_,D
	295	,D,S,_)) = 35
	296	blobLookup (N (_,S,_
	297	,D,_,S
	298	,_,S,D)) = 36
	299	blobLookup (N (_,D,_
	300	,S,_,S
	301	,D,S,S)) = 37
	302	blobLookup (N (S,S,D
	303	,S,_,S
	304	,D,S,D)) = 38
	305	blobLookup (N (D,S,S
	306	,S,_,S
	307	,D,S,D)) = 39
	308	blobLookup (N (S,S,D
	309	,S,_,S
	310	,D,S,S)) = 42
	311	blobLookup (N (D,S,S
	312	,S,_,S
	313	,S,S,D)) = 43
	314	blobLookup (N (_,S,D
	315	,D,_,S
	316	,_,S,S)) = 44
	317	blobLookup (N (D,S,S
	318	,S,_,S
	319	,_,D,_)) = 45
	320	blobLookup (N (S,S,D
	321	,S,_,S
	322	,_,D,_)) = 46
	323	blobLookup (N (D,S,_
	324	,S,_,D
	325	,S,S,_)) = 47
	326	blobLookup (N (D,S,D
	327	,S,_,S
	328	,S,S,D)) = 48
	329	blobLookup (N (D,S,D
	330	,S,_,S
	331	,D,S,S)) = 49

+33

-0

src/SDLClient.hs less more

	1	{-# LANGUAGE RecordWildCards #-}
	2
	3	module Main where
	4
	5	import Control.Monad
	6	import qualified Data.Map as M
	7	import qualified Graphics.UI.SDL as SDL
	8	import System.Environment (getArgs)
	9	import System.Random
	10
	11	import SDLClient.SpriteSheet
	12
	13	rmap :: IO (M.Map (Int, Int) Int)
	14	rmap = fmap M.fromList $ sequence $ [ go (x, y) \| x <- [0..11], y <- [0..11] ]
	15	where go (x, y) = do r <- randomIO
	16	return ((x, y), r `mod` 3)
	17
	18	main :: IO ()
	19	main = do
	20	(texture:_) <- getArgs
	21	SDL.init [SDL.InitVideo, SDL.InitAudio]
	22	screen <- SDL.setVideoMode 640 480 8 [SDL.SWSurface]
	23	s1 <- loadSpriteSheet "test.texture"
	24	s2 <- loadSpriteSheet "rug.texture"
	25	s3 <- loadSpriteSheet "black.texture"
	26	let toSpriteSheet 0 = s1
	27	toSpriteSheet 1 = s2
	28	toSpriteSheet 2 = s3
	29	pic <- rmap
	30	drawMap toSpriteSheet pic screen
	31	SDL.updateRect screen $ SDL.Rect 0 0 640 480
	32	_ <- getLine
	33	SDL.quit

textures/black.texture less more

Binary diff not shown

textures/circle.texture less more

Binary diff not shown

textures/rug.texture less more

Binary diff not shown

textures/test.texture less more

Binary diff not shown