diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2016, jeremy@n-heptane.com + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of jeremy@n-heptane.com nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Minecraft/Anvil.hs b/Minecraft/Anvil.hs new file mode 100644 --- /dev/null +++ b/Minecraft/Anvil.hs @@ -0,0 +1,276 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +module Minecraft.Anvil where + +import Control.Monad (when, replicateM) +import Control.Monad.State.Strict (execStateT, modify') +import Codec.Compression.Zlib (decompress, compress) +import Data.Bits (shiftR, shiftL, (.&.), (.|.)) +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as LB +import Data.Data (Data, Typeable) +import Data.List (mapAccumL) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.NBT (NBT) +import Data.Serialize (Serialize(..), Get, Put, decodeLazy, encodeLazy, getLazyByteString, getWord8, getWord32be, putLazyByteString, putWord8, putWord32be) +import Data.Time.Clock.POSIX (POSIXTime) +import Data.Vector (Vector) +import qualified Data.Vector as Vector +import Data.Word (Word8, Word32) +import GHC.Generics +import Pipes.ByteString (fromHandle, toHandle) +import Pipes.Cereal (decodeGet, encodePut) +import Pipes.Parse (runStateT) +import Pipes (Pipe, runEffect, (>->), await, each, yield) +import System.IO (Handle, hSeek, SeekMode(AbsoluteSeek)) + +{- +regionX :: Double -- ^ chunkX + -> Int +regionX x = floor (x / 32.0) + +regionY :: Double -- ^ chunkY + -> Int +regionY y = foor (y / 32.0) +-} + +type ChunkX = Int +type ChunkZ = Int +type RegionX = Int +type RegionZ = Int + +type ChunkMap = Map (ChunkX, ChunkZ) (ChunkData, POSIXTime) + +regionX :: ChunkX + -> RegionX +regionX x = x `shiftR` 5 + +regionZ :: ChunkZ + -> RegionZ +regionZ z = z `shiftR` 5 + +chunkIndex :: (ChunkX, ChunkZ) + -> Int +chunkIndex (x, z) = (x `pmod` 32) + ((z `pmod` 32) * 32) + where + pmod n m = + let n' = n `mod` m + in if (n' >= 0) + then n' + else n' + m + +type Word24 = Word32 + +-- | ChunkLocation +-- +-- ChunkLocation 0 0 means chunk is not present in the file +data ChunkLocation = ChunkLocation + { chunkOffset :: Word24 -- ^ number of 4KiB sectors from start of file + , chunkLength :: Word8 -- ^ length of chunk -- units are 4KiB sectors, rounded up + } + deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) + +-- | ChunkLocation 0 0 means chunk is not present in the file +emptyChunkLocation :: ChunkLocation +emptyChunkLocation = ChunkLocation 0 0 + +putChunkLocation :: ChunkLocation -> Put +putChunkLocation (ChunkLocation offset len) = + do putWord8 (fromIntegral ((offset `shiftR` 16) .&. 0xFF)) + putWord8 (fromIntegral ((offset `shiftR` 8) .&. 0xFF)) + putWord8 (fromIntegral (offset .&. 0xFF)) + putWord8 len + +getChunkLocation :: Get ChunkLocation +getChunkLocation = + do b2 <- fromIntegral <$> getWord8 + b1 <- fromIntegral <$> getWord8 + b0 <- fromIntegral <$> getWord8 + len <- fromIntegral <$> getWord8 + pure (ChunkLocation ((b2 `shiftL` 16) .|. (b1 `shiftL` 8) .|. b0) len) + +instance Serialize ChunkLocation where + put = putChunkLocation + get = getChunkLocation + +data AnvilHeader = AnvilHeader + { locations :: Vector ChunkLocation + , timestamps :: Vector POSIXTime + } + deriving (Eq, Ord, Show, Data, Typeable, Generic) + +showAnvilHeader :: AnvilHeader -> String +showAnvilHeader ah = show $ AnvilHeader { locations = Vector.filter (/= emptyChunkLocation) (locations ah) + , timestamps = Vector.filter (/= 0) (timestamps ah) + } + +-- guessing on the timestamp format a bit +putTimestamp :: POSIXTime -> Put +putTimestamp t = putWord32be (round t) + +getTimestamp :: Get POSIXTime +getTimestamp = + do l <- getWord32be + pure $ (realToFrac l) + +putAnvilHeader :: AnvilHeader -> Put +putAnvilHeader (AnvilHeader locations timestamps) + | (Vector.length locations /= 1024) || (Vector.length timestamps /= 1024) = + error "putAnvilHeader: locations and timestamps fields must be exactly 1024 entries long." + | otherwise = + do mapM_ putChunkLocation (Vector.toList locations) + mapM_ putTimestamp (Vector.toList timestamps) + +getAnvilHeader :: Get AnvilHeader +getAnvilHeader = + do locations <- replicateM 1024 getChunkLocation + timestamps <- replicateM 1024 getTimestamp + pure $ AnvilHeader (Vector.fromList locations) (Vector.fromList timestamps) + +instance Serialize AnvilHeader where + put = putAnvilHeader + get = getAnvilHeader + +emptyAnvilHeader :: AnvilHeader +emptyAnvilHeader = + AnvilHeader { locations = Vector.replicate 1024 emptyChunkLocation + , timestamps = Vector.replicate 1024 0 + } + +-- | make an 'AnvilHeader' +-- +-- assumes the chunks will be written in the same order as they appear in the list +mkAnvilHeader :: [((ChunkX, ChunkZ), (ChunkData, POSIXTime))] + -> AnvilHeader +mkAnvilHeader chunks = + let timestamps' = map (\(i, (_, t)) -> (chunkIndex i, t)) chunks + locations' = snd $ mapAccumL mkLocation 0x2 chunks -- ^ first chunk is at sector 0x2, after the AnvilHeader + in AnvilHeader { locations = (locations emptyAnvilHeader) Vector.// locations' + , timestamps = (timestamps emptyAnvilHeader) Vector.// timestamps' + } + where + mkLocation :: Word24 -> ((ChunkX, ChunkZ), (ChunkData, POSIXTime)) -> (Word24, (Int, ChunkLocation)) + mkLocation offset (chunkPos, (chunkData, _)) = + let paddedSectorLength = ((chunkDataLength chunkData) + 4 + 4095) `div` 4096 + offset' = offset + paddedSectorLength + in (offset', (chunkIndex chunkPos, ChunkLocation offset (fromIntegral paddedSectorLength))) + +data CompressionType + = GZip -- ^ unused in practice + | Zlib + deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) + +-- | ChunkData +-- +-- Compressed chunk data +data ChunkData = ChunkData + { chunkDataLength :: Word32 -- ^ length of chunkData + 1 + , chunkDataCompression :: CompressionType -- ^ compression type + , chunkData :: ByteString -- ^ compressed data (length - 1) + } + deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) + +putChunkData :: ChunkData -> Put +putChunkData cd = + do putWord32be (chunkDataLength cd) + case chunkDataCompression cd of + GZip -> putWord8 1 + Zlib -> putWord8 2 + putLazyByteString (chunkData cd) + +getChunkData :: Get ChunkData +getChunkData = + do len <- getWord32be + comp <- do w <- getWord8 + case w of + 1 -> pure GZip + 2 -> pure Zlib + _ -> error $ "Unknown compression code in getChunkData: " ++ show (len, w) + bs <- getLazyByteString (fromIntegral (len - 1)) + pure $ ChunkData len comp bs + +instance Serialize ChunkData where + put = putChunkData + get = getChunkData + +-- | read 'ChunkData' from a Seekable 'Handle' +readChunkData :: Handle -> ChunkLocation -> IO (Maybe ChunkData) +readChunkData h chunkLocation + | chunkLocation == emptyChunkLocation = pure Nothing + | otherwise = + do hSeek h AbsoluteSeek (fromIntegral $ ((chunkOffset chunkLocation) * 4096)) + (r, _) <- runStateT (decodeGet getChunkData) (fromHandle h) + case r of + (Left err) -> error err + (Right cd) -> pure (Just cd) + +-- | write 'ChunkData' to a Seekable 'Handle' +-- +-- FIXME: chunks are supposed to be guaranteed less than 1MB +{- +writeChunkData :: Handle -> ChunkData -> IO () +writeChunkData h chunkData = + do runEffect $ (encodePut (putChunkData chunkData)) >-> (toHandle h) + let padding = 4096 - ((chunkDataLength chunkData + 4) `mod` 4096) + when (padding > 0) (B.hPutStr h (B.replicate (fromIntegral padding) 0)) +-} + +writeChunkData :: (Monad m) => Pipe ChunkData B.ByteString m () +writeChunkData = do + chunkData <- await + encodePut (putChunkData chunkData) + let padding = 4096 - ((chunkDataLength chunkData + 4) `mod` 4096) + when (padding > 0) (yield (B.replicate (fromIntegral padding) 0)) + +{- + + do bytes <- execStateT (runEffect $ (encodePut (putChunkData chunkData)) >-> counter >-> (toHandle h)) 0 + pure bytes + where + counter = + do bs <- await + modify' $ \i -> i + B.length bs + yield bs +-} +{- +readChunkData :: Handle -> ChunkLocation -> IO (Maybe ChunkData) +readChunkData h chunkLocation + | chunkLocation == emptyChunkLocation = pure Nothing + | otherwise = + do hSeek h AbsoluteSeek (fromIntegral $ ((chunkOffset chunkLocation) * 4096)) + (r, _) <- runStateT (decodeGet getChunkData) (fromHandle h) + case r of + (Left err) -> error err + (Right cd) -> pure (Just cd) +-} +decompressChunkData :: ChunkData -> Either String NBT +decompressChunkData cd + | chunkDataCompression cd == Zlib = + decodeLazy (decompress (chunkData cd)) + | otherwise = error $ "decompressChunkData not implemented for " ++ show (chunkDataCompression cd) + +-- | NBT needs to be a Chunk +compressChunkData :: NBT -> ChunkData +compressChunkData nbt = + let d = compress (encodeLazy nbt) + in ChunkData { chunkDataLength = 1 + fromIntegral (LB.length d) + , chunkDataCompression = Zlib + , chunkData = d + } + +writeChunkMap :: Handle -> ChunkMap -> IO () +writeChunkMap h chunkMap = + do hSeek h AbsoluteSeek 0 + let chunks = Map.toAscList chunkMap + runEffect $ (encodePut (putAnvilHeader (mkAnvilHeader chunks))) >-> (toHandle h) + runEffect $ (each $ map (fst . snd) chunks) >-> writeChunkData >-> (toHandle h) +-- runEffect $ (encodePut (putAnvilHeader emptyAnvilHeader)) >-> (toHandle h) + -- [(ChunkPos, ChunkData)] -> [(ChunkPos, Length)] + -- chunks' <- mapM (\(chunkPos, (cd, modTime)) -> do i <- writeChunkData h cd ; pure (chunkPos, (i, modTime))) chunks + pure () diff --git a/Minecraft/Block.hs b/Minecraft/Block.hs new file mode 100644 --- /dev/null +++ b/Minecraft/Block.hs @@ -0,0 +1,333 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +module Minecraft.Block where + +import Data.Data +import GHC.Generics + +data Wood + = OakWood + | SpruceWood + | BirchWood + | JungleWood + deriving (Eq, Ord, Read, Show, Data, Typeable, Generic, Enum) + +data WoodDirection + = FacingUpDown + | FacingEastWest + | FacingNorthSouth + | OnlyBark + deriving (Eq, Ord, Read, Show, Data, Typeable, Generic, Enum) + +data Wood2 + = AcaciaWood + | DarkOakWood + deriving (Eq, Ord, Read, Show, Data, Typeable, Generic, Enum) + +data Leaves + = OakLeaves + | SpruceLeaves + | BirchLeaves + | JungleLeaves + | OakLeavesNoDecay + | SpruceLeavesNoDecay + | BirchLeavesNoDecay + | JungleLeavesNoDecay + | OakLeavesCheckDecay + | SpruceLeavesCheckDecay + | BirchLeavesCheckDecay + | JungleLeavesCheckDecay + | OakLeavesNoDecayCheckDecay + | SpruceLeavesNoDecayCheckDecay + | BirchLeavesNoDecayCheckDecay + | JungleLeavesNoDecayCheckDecay + deriving (Eq, Ord, Read, Show, Data, Typeable, Generic, Enum) + +data Leaves2 + = AcaciaLeaves + | DarkOakLeaves + | AcaciaLeavesNoDecay + | DarkOakLeavesNoDecay + | AcaciaLeavesCheckDecay + | DarkOakLeavesCheckDecay + | AcaciaLeavesNoDecayCheckDecay + | DarkOakLeavesNoDecayCheckDecay + deriving (Eq, Ord, Read, Show, Data, Typeable, Generic, Enum) + +data Stone + = Stone + | Granite + | PolishedGranite + | Diorite + | PolishedDiorite + | Andesite + | PolishedAndesite + deriving (Eq, Ord, Read, Show, Data, Typeable, Generic, Enum) + +data Dirt + = Dirt + | CoarseDirt + | Podzol + deriving (Eq, Ord, Read, Show, Data, Typeable, Generic, Enum) + +data Block + = Air + | StoneBlock Stone + | GrassBlock + | DirtBlock Dirt + | Cobblestone + | WoodPlanks + | Sapling + | Bedrock + | Water + | StationaryWater + | Lava + | StationaryLava + | Sand + | Gravel + | GoldOre + | IronOre + | CoalOre + | Wood + | Leaves + | Sponge + | Glass + | LapisLazuliOre + | LapisLazuliBlock + | Dispenser + | Sandstone + | NoteBlock + | Bed + | PoweredRail + | DetectorRail + | StickyPiston + | Cobweb + | Grass + | DeadBush + | Piston + | PistonHead + | Wool + | PistonExtension + | Dandelion + | Poppy + | BrownMushroom + | RedMushroom + | BlockOfGold + | BlockOfIron + | DoubleStoneSlab + | StoneSlab + | Bricks + | TNT + | Bookshelf + | MossStone + | Obsidian + | Torch + | Fire + | MonsterSpawner + | OakWoodStairs + | Chest + | RedstoneWire + | DiamondOre + | BlockOfDiamond + | CraftingTable + | Wheat + | Farmland + | Furnace + | BurningFurnace + | StandingSign + | OakDoor + | Ladder + | Rail + | CobblestoneStairs + | WallSign + | Level + | StonePresurePlate + | IronDoor + | WoodenPressurePlate + | RedstoneOre + | GlowingRedstoneOre + | RedstoneTorchUnlit + | RedstoneTorch + | StoneButton + | SnowLayer + | Ice + | Snow + | Cactus + | Clay + | SugarCane + | JukeBox + | Fence + | Pumpkin + | Netherrack + | SoulSand + | Glowstone + | NetherPortal + | JackOLantern + | Cake + | RedstoneRepeaterUnpowered + | RedstoneRepeaterPowered + | StainedGlass + | Trapdoor + | MonsterEgg + | StoneBricks + | BrownMushroomBlock + | RedMushroomBlock + | IronBars + | GlassPane + | Melon + | PumpkinStem + | MelonStem + | Vines + | FenceGate + | BrickStairs + | StoneBrickStairs + | Mycelium + | LilyPad + | NetherBrick + | NetherBrickFence + | NetherBrickStairs + | NetherWart + | EnchantmentTable + | BrewingStand + | Cauldron + | EndPortal + | EndPortalFrame + | EndStone + | DragonEgg + | RedstoneLampUnlit + | RedstoneLampLit + | DoubleWoodenSlab + | WoodenSlab + | Cocoa + | SandstoneStairs + | EmeraldOre + | EnderChest + | TripwireHook + | Tripwire + | BlockOfEmerald + | SpruceWoodStairs + | BirchWoodStairs + | JungleWoodStairs + | CommandBlock + | Beacon + | CobblestoneWall + | FlowerPot + | Carrot + | Potato + | WoodenButton + | ModHead + | Anvil + | TrappedChest + | WeightedPressurePlateLight + | WeightedPressurePlateHeavy + | RedstoneComparator + | RedstoneComparatorDeprecated + | DaylightSensor + | BlockOfRedstone + | NetherQuartzOre + | Hopper + | BlockOfQuartz + | QuartzStairs + | ActivatorRails + | Dropper + | StainedClay + | StainedGlassPane + | Leaves2 + | Wood2 + | AcaciaWoodStairs + | DarkOakWoodStairs + | SlimeBlock + | Barrier + | IronTrapdoor + | Prismarine + | SeaLantern + | HayBale + | Carpet + | HardenedClay + | BlockOfCoal + | PackedIce + | LargeFlowers + | StandingBarrier + | WallBanner + | InvertedDaylightSensor + | RedSandstone + | RedSandstoneStairs + | DoubleRedSandstoneStairs + | RedSandstoneSlab + | SpruceFenceGate + | BirchFenceGate + | JungleFenceGate + | DarkOakFenceGate + | AcaciaFenceGate + | SpruceFence + | BirchFence + | JungleFence + | DarkOakFence + | AcaciaFence + | SpruceDoor + | BirchDoor + | JungleDoor + | AcaciaDoor + | DarkOakDoor + | EndRod + | ChorusPlant + | ChorusFlower + | PurpurBlock + | PurpurPillar + | PurpurStairs + | PurpurDoubleSlab + | PurpurSlab + | EndStoneBricks + | BeetrootSeeds + | GrassPath + | EndGateway + | RepeatingCommandBlock + | ChainCommandBlock + | FrostedIce + | Undefined213 + | Undefined214 + | Undefined215 + | Undefined216 + | Undefined217 + | Undefined218 + | Undefined219 + | Undefined220 + | Undefined221 + | Undefined222 + | Undefined223 + | Undefined224 + | Undefined225 + | Undefined226 + | Undefined227 + | Undefined228 + | Undefined229 + | Undefined230 + | Undefined231 + | Undefined232 + | Undefined233 + | Undefined234 + | Undefined235 + | Undefined236 + | Undefined237 + | Undefined238 + | Undefined239 + | Undefined240 + | Undefined241 + | Undefined242 + | Undefined243 + | Undefined244 + | Undefined245 + | Undefined246 + | Undefined247 + | Undefined248 + | Undefined249 + | Undefined250 + | Undefined251 + | Undefined252 + | Undefined253 + | Undefined254 + | StructureBlock + deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) + + + diff --git a/Minecraft/Chunk.hs b/Minecraft/Chunk.hs new file mode 100644 --- /dev/null +++ b/Minecraft/Chunk.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +module Minecraft.Chunk where + +import Control.Lens.TH (makeLenses) +import Data.Array.Unboxed (IArray, UArray, listArray, elems) +import Data.Data (Data) +import Data.Time.Clock.POSIX (POSIXTime) +import Data.Typeable (Typeable) +import Data.NBT +import Data.Int (Int8, Int32, Int64) +import Data.Text (Text) +import Data.Vector (Vector) +import qualified Data.Vector as Vector +import GHC.Generics (Generic) +import Minecraft.Core (BlockId(..), Difficulty(..), GameMode(..), ToNBT(..), ToNBTContents(..), XYZ(..), sunrise) + +vectorArray :: (IArray UArray e) => Vector e -> UArray Int32 e +vectorArray v = listArray (0, fromIntegral ((Vector.length v) - 1)) (Vector.toList v) + +data Section = Section + { _Y :: Int8 -- ^ Y index (not coordinate) of this section. Range 0 - 15. + , _Blocks :: Vector BlockId -- ^ 4096 + , _Add :: Maybe (Vector Int8) -- ^ 2048 + , _BlockData :: Vector Int8 -- ^ 2048 + , _BlockLight :: Vector Int8 -- ^ 2048 + , _SkyLight :: Vector Int8 -- ^ 2048 + } + deriving (Eq, Ord, Show, Typeable, Generic) +makeLenses ''Section + +-- FIXME: add range checks +-- FIMXE: add 'Add' support +instance ToNBTContents Section where + toNBTContents section = + (CompoundTag + [ NBT "Y" (ByteTag (_Y section)) + , NBT "Blocks" (ByteArrayTag (vectorArray (Vector.map _unBlockId (_Blocks section)))) + , NBT "Data" (ByteArrayTag (vectorArray (_BlockData section))) +-- , NBT "Add" + , NBT "BlockLight" (ByteArrayTag (vectorArray (_BlockLight section))) + , NBT "SkyLight" (ByteArrayTag (vectorArray (_SkyLight section))) + ]) + +emptySection :: Section +emptySection = Section + { _Y = 0 + , _Blocks = Vector.replicate 4096 (BlockId 0) + , _Add = Nothing + , _BlockData = Vector.replicate 2048 0 + , _BlockLight = Vector.replicate 2048 0 + , _SkyLight = Vector.replicate 2048 0 + } + +-- FIXME +data EntityData = EntityData + { + } + deriving (Eq, Ord, Show, Typeable, Generic) +makeLenses ''EntityData + +-- FIXME +data BlockEntity = BlockEntity + { + } + deriving (Eq, Ord, Show, Typeable, Generic) +makeLenses ''BlockEntity + +-- FIXME +data TileTick = TileTick + { + } + deriving (Eq, Ord, Show, Typeable, Generic) +makeLenses ''TileTick + +data Chunk = Chunk + { _xPos :: Int32 + , _zPos :: Int32 + , _LastUpdate :: POSIXTime + , _LightPopulated :: Bool + , _TerrainPopulated :: Bool + , _V :: Int8 + , _InhabitedTime :: Int64 + , _Biomes :: Vector Int8 -- UArray Int32 Int8 + , _HeightMap :: Vector Int32 -- UArray Int32 Int32 + , _Sections :: [Section] + , _Entities :: [EntityData] + , _TileEntities :: [BlockEntity] + , _TileTicks :: [TileTick] + } + deriving (Eq, Ord, Show, Typeable, Generic) +makeLenses ''Chunk + +emptyChunk :: Chunk +emptyChunk = Chunk + { _xPos = 0 + , _zPos = 0 + , _LastUpdate = 0 + , _LightPopulated = False + , _TerrainPopulated = True + , _V = 1 + , _InhabitedTime = 0 + , _Biomes = Vector.replicate 256 (-1) + , _HeightMap = Vector.replicate 1024 0 + , _Sections = [] + , _Entities = [] + , _TileEntities = [] + , _TileTicks = [] + } + +instance ToNBTContents Chunk where + toNBTContents chunk = + (CompoundTag + [ NBT "xPos" (IntTag (_xPos chunk)) + , NBT "zPos" (IntTag (_zPos chunk)) + , NBT "LastUpdate" (toNBTContents (_LastUpdate chunk)) + , NBT "LightPopulated" (toNBTContents (_LightPopulated chunk)) + , NBT "TerrainPopulated" (toNBTContents (_TerrainPopulated chunk)) -- ^ FIXME: should be not-present for False + , NBT "V" (ByteTag (_V chunk)) + , NBT "InhabitedTime" (LongTag (_InhabitedTime chunk)) + , NBT "Biomes" (ByteArrayTag (vectorArray (_Biomes chunk))) + , NBT "HeightMap" (IntArrayTag (vectorArray (_HeightMap chunk))) + , NBT "Sections" (ListTag (listArray (0, fromIntegral (length (_Sections chunk) - 1)) (map toNBTContents (_Sections chunk)))) + ]) + +instance ToNBT Chunk where + toNBT chunk = + (NBT "" (CompoundTag [ NBT "Level" (toNBTContents chunk) ])) + diff --git a/Minecraft/Command.hs b/Minecraft/Command.hs new file mode 100644 --- /dev/null +++ b/Minecraft/Command.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +module Minecraft.Command where + +import Data.Data (Data) +import Data.Typeable (Typeable) +import Data.Int (Int8, Int16, Int32, Int64) +import Data.Monoid ((<>), mconcat, mempty) +import Data.NBT +import Data.Word (Word, Word8) +import Data.Text (Text) +import Data.Text.Lazy.Builder (Builder) +import qualified Data.Text.Lazy.Builder as B +import GHC.Generics +import Minecraft.Core +import TextShow (showb) + +data Command + = Give Target Item (Maybe Int6) (Maybe Int64) (Maybe NBT) + deriving (Eq, Show) + +(<+>) :: Builder -> Builder -> Builder +a <+> b = a <> B.singleton ' ' <> b + +() :: (Render b) => Builder -> Maybe b -> Builder +a Nothing = a +a (Just b) = a <+> (render b) + +instance Render NBT where + render nbt = error "Render NBT not implemented." + +instance Render Command where + render command = + case command of + (Give target item Nothing Nothing Nothing) -> + "give" <+> render target <+> showb item + (Give target item mAmount mData mDataTag) -> + "give" <+> render target <+> showb item <+> (maybe "1" render mAmount) <+> (maybe "0" render mData) mDataTag + diff --git a/Minecraft/Core.hs b/Minecraft/Core.hs new file mode 100644 --- /dev/null +++ b/Minecraft/Core.hs @@ -0,0 +1,428 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +module Minecraft.Core where + +import Control.Lens.TH (makeLenses) +import qualified Data.Array as Array +import Data.Data +import Data.List (intersperse) +import Data.Maybe (maybe, fromMaybe) +import Data.Monoid ((<>), mconcat, mempty) +import Data.NBT +import Data.Int (Int8, Int16, Int32, Int64) +import Data.Time.Clock.POSIX (POSIXTime) +import Data.Word (Word, Word8) +import Data.Text (Text) +import Data.Text.Lazy.Builder (Builder) +import qualified Data.Text.Lazy.Builder as B +import GHC.Generics +import TextShow + +type Int6 = Int8 + +class Render a where + render :: a -> Builder + +instance Render a => Render (Maybe a) where + render Nothing = mempty + render (Just a) = render a + +instance Render Int6 where + render i = B.fromString (show i) + +instance Render Int64 where + render i = B.fromString (show i) + +class ToNBT a where + toNBT :: a -> NBT + +class ToNBTContents a where + toNBTContents :: a -> NbtContents + +instance ToNBTContents Bool where + toNBTContents False = ByteTag 0 + toNBTContents True = ByteTag 1 + +instance ToNBTContents Int8 where + toNBTContents i = ByteTag i + +instance ToNBTContents Int16 where + toNBTContents i = ShortTag i + +instance ToNBTContents Int32 where + toNBTContents i = IntTag i + +instance ToNBTContents Int64 where + toNBTContents i = LongTag i + +instance ToNBTContents Float where + toNBTContents f = FloatTag f + +instance ToNBTContents Double where + toNBTContents d = DoubleTag d + +instance ToNBTContents Text where + toNBTContents t = StringTag t + +instance ToNBTContents POSIXTime where + toNBTContents t = LongTag (round (t * 1000)) + +instance ToNBTContents a => ToNBTContents [a] where + toNBTContents l = ListTag (Array.listArray (0, (fromIntegral $ length l) - 1) (map toNBTContents l)) + +instance ToNBTContents [NbtContents] where + toNBTContents l = ListTag (Array.listArray (0, (fromIntegral $ length l) - 1) l) + +data Coordinate + = Absolute Int + | Relative Int + deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) + +instance Render Coordinate where + render (Absolute i) = B.fromString (show i) + render (Relative 0) = B.singleton '~' + render (Relative i) = B.singleton '~' <> B.fromString (show i) + +data TargetVariable + = NearestPlayer + | RandomPlayer + | AllPlayers + | AllEntities + deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) + +instance Render TargetVariable where + render t = + case t of + NearestPlayer -> "@p" + RandomPlayer -> "@r" + AllPlayers -> "@a" + AllEntities -> "@e" + +type Name = Text + +instance Render Text where + render t = B.fromText t + +data GameMode + = AllModes + | SurvivalMode + | CreativeMode + | AdventureMode + | SpectatorMode + deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) + +instance Render GameMode where + render m = + case m of + AllModes -> "-1" + SurvivalMode -> "0" + CreativeMode -> "1" + AdventureMode -> "2" + SpectatorMode -> "3" + +instance ToNBTContents GameMode where + toNBTContents gm = + IntTag $ case gm of + AllModes -> (-1) + SurvivalMode -> 0 + CreativeMode -> 1 + AdventureMode -> 2 + SpectatorMode -> 3 + + +newtype BlockId = BlockId { _unBlockId:: Int8 } + deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) +makeLenses ''BlockId + +newtype EntityId = EntityId { unEntityId:: Int8 } + deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) + +data Entity + -- Drops + = Item + | XPOrb + -- Immobile + | LeashKnot + | Painting + | ItemFrame + | ArmorStand + | EnderCrystal + -- Projectiles + | ThrownEgg + | Arrow + | Snowball + | Fireball + | SmallFireball + | ThrownEnderpearl + | EyeOfEnderSignal + | ThrownPotion + | ThrownExpBottle + | WitherSkull + | FireworksRocketEntity + -- Blocks + | PrimedTnt + | FailingSand + -- Vehicles + | MinecartCommandBlock + | Boat + | MinecartRideable + | MinecartChest + | MinecartFurnace + | MinecartTNT + | MinecartHopper + | MinecartSpawner + -- Generic + | Mob + | Monster + -- Hostile Mobs + | Creeper + | Skeleton + | Spider + | Giant + | Zombie + | Slime + | Ghast + | PigZombie + | Enderman + | CaveSpider + | Silverfish + | Blaze + | LavaSlime + | EnderDragon + | WitherBoss + | Witch + | Endermite + | Guardian + | Shulker +-- | KillerRabbit -- ? + -- Passive Mobs + | Bat + | Pig + | Sheep + | Cow + | Chicken + | Squid + | Wolf + | MooshroomCow + | SnowMan + | Ozelot + | VillagerGolem + | EntityHorse + | Rabbit + -- NPCs + | Villager + deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) + +toEntityId :: Entity -> EntityId +toEntityId entity = + case entity of + Item -> EntityId 1 + Creeper -> EntityId 50 + +instance Render EntityId where + render (EntityId n) = B.fromString (show n) + +instance Render Entity where + render e = + case e of + Item -> "Item" + XPOrb -> "XPOrb" + LeashKnot -> "LeashKnot" + Painting -> "Painting" + ItemFrame -> "ItemFrame" + ArmorStand -> "ArmorStand" + EnderCrystal -> "EnderCrystal" + -- Projectiles + ThrownEgg -> "ThrownEgg" + Arrow -> "Arrow" + Snowball -> "Snowball" + Fireball -> "Fireball" + SmallFireball -> "SmallFireball" + ThrownEnderpearl -> "ThrownEnderpearl" + EyeOfEnderSignal -> "EyeOfEnderSignal" + ThrownPotion -> "ThrownPotion" + ThrownExpBottle -> "ThrownExpBottle" + WitherSkull -> "WitherSkull" + FireworksRocketEntity -> "FireworksRocketEntity" + -- Blocks + PrimedTnt -> "PrimedTnt" + FailingSand -> "FailingSand" + -- Vehicles + MinecartCommandBlock -> "MinecartCommandBlock" + Boat -> "Boat" + MinecartRideable -> "MinecartRideable" + MinecartChest -> "MinecartChest" + MinecartFurnace -> "MinecartFurnace" + MinecartTNT -> "MinecartTNT" + MinecartHopper -> "MinecartHopper" + MinecartSpawner -> "MinecartSpawner" + -- Generic + Mob -> "Mob" + Monster -> "Monster" + -- Hostile Mobs + Creeper -> "Creeper" + Skeleton -> "Skeleton" + Spider -> "Spider" + Giant -> "Giant" + Zombie -> "Zombie" + Slime -> "Slime" + Ghast -> "Ghast" + PigZombie -> "PigZombie" + Enderman -> "Enderman" + CaveSpider -> "CaveSpider" + Silverfish -> "Silverfish" + Blaze -> "Blaze" + LavaSlime -> "LavaSlime" + EnderDragon -> "EnderDragon" + WitherBoss -> "WitherBoss" + Witch -> "Witch" + Endermite -> "Endermite" + Guardian -> "Guardian" + Shulker -> "Shulker" +-- Rabbit -> "Rabbit" + -- Passive Mobs + Bat -> "Bat" + Pig -> "Pig" + Sheep -> "Sheep" + Cow -> "Cow" + Chicken -> "Chicken" + Squid -> "Squid" + Wolf -> "Wolf" + MooshroomCow -> "MooshroomCow" + SnowMan -> "SnowMan" + Ozelot -> "Ozelot" + VillagerGolem -> "VillagerGolem" + EntityHorse -> "EntityHorse" + Rabbit -> "Rabbit" + -- NPCs + Villager -> "Villager" + +data Op + = Equal + | NotEqual + deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) + +instance Render Op where + render op = + case op of + Equal -> "=" + NotEqual -> "=!" + +data TargetArgument + = TargetX Coordinate + | TargetY Coordinate + | TargetZ Coordinate + | RadiusMax Coordinate + | RadiusMin Coordinate + | GameMode GameMode + | Count Int + | XpLevelMax Word + | XpLevelMin Word + | ScoreMax Name Word + | ScoreMin Name Word + | Team Op Name + | Name Op Name + | Dx Coordinate + | Dy Coordinate + | Dz Coordinate + | RxMax Double + | RxMin Double + | RyMax Double + | RyMin Double + | Type Op Entity + deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) + +instance Render TargetArgument where + render arg = + case arg of + (Count n) -> "count="<>B.fromString (show n) + (Type op entity) -> "type" <> render op <> render entity + +data TargetSelector = TargetSelector TargetVariable [TargetArgument] + deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) + +instance Render TargetSelector where + render (TargetSelector var []) = + render var + render (TargetSelector var args) = + render var <> B.singleton '[' <> mconcat (intersperse (B.singleton ',') $ map render args) <> B.singleton ']' + +data Target + = Player Name + | TS TargetSelector + deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) + +instance Render Target where + render (Player name) = render name + render (TS ts) = render ts + +data Item + = IronShovel + | IronPickaxe + deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) +{- +instance Render Item where + render item = + case item of + IronShovel -> "minecraft:iron_shovel" + IronPickaxe -> "minecraft:iron_pickaxe" +-} +instance TextShow Item where + showb item = + case item of + IronShovel -> "minecraft:iron_shovel" + IronPickaxe -> "minecraft:iron_pickaxe" + +data Difficulty + = Peaceful + | Easy + | Normal + | Hard + deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) + +instance ToNBTContents Difficulty where + toNBTContents difficulty = + ByteTag $ case difficulty of + Peaceful -> 0 + Easy -> 1 + Normal -> 2 + Hard -> 3 + +-- | time of day values +sunrise, midday, sunset, midnight, nextday :: Int64 +sunrise = 0 +midday = 6000 +sunset = 12000 +midnight = 18000 +nextday = 24000 + +data Dimension + = Nether + | Overworld + | End + deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) + +instance ToNBTContents Dimension where + toNBTContents dimension = + IntTag $ case dimension of + Nether -> (-1) + Overworld -> 0 + End -> 1 + +data XYZ = XYZ + { _x :: Int32 + , _y :: Int32 + , _z :: Int32 + } + deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) +makeLenses ''XYZ + +data Attribute = Attribute + deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) + +instance ToNBTContents Attribute where + toNBTContents = error "ToNBTContent Attribute not implemented." diff --git a/Minecraft/Level.hs b/Minecraft/Level.hs new file mode 100644 --- /dev/null +++ b/Minecraft/Level.hs @@ -0,0 +1,219 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +module Minecraft.Level where + +import Control.Lens.TH (makeLenses) +import Data.Data (Data) +import Data.Time.Clock.POSIX (POSIXTime) +import Data.Typeable (Typeable) +import Data.NBT +import Data.Int (Int32, Int64) +import Data.Text (Text) +import GHC.Generics (Generic) +import Minecraft.Core (Difficulty(..), GameMode(..), ToNBT(..), ToNBTContents(..), XYZ(..), sunrise) +import Minecraft.Player (Player(..), defaultPlayer) + +data GeneratorName + = Default + | Flat + | LargeBiomes + | Amplified + | Customized + | DebugAllBlockStates + deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) + +instance ToNBTContents GeneratorName where + toNBTContents generatorName = + StringTag $ case generatorName of + Default -> "default" + Flat -> "flat" + LargeBiomes -> "largeBiomes" + Amplified -> "amplified" + Customized -> "customized" + DebugAllBlockStates -> "debug_all_block_states" + +data GameRules = GameRules + { _commandBlockOutput :: Bool -- ^ True + , _doDaylightCycle :: Bool -- ^ True + , _doFireTick :: Bool -- ^ True + , _doMobLoot :: Bool -- ^ True + , _doMobSpawning :: Bool -- ^ True + , _doTileDrops :: Bool -- ^ True + , _keepInventory :: Bool -- ^ False + , _logAdminCommands :: Bool -- ^ True + , _mobGriefing :: Bool -- ^ True + , _naturalRegeneration :: Bool -- ^ True + , _randomTickSpeed :: Int32 -- ^ 3 + , _sendCommandFeedback :: Bool -- ^ True + , _showDeathMessages :: Bool -- ^ True + , _reducedDebugInfo :: Bool -- ^ False + } + deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) + +defaultGameRules :: GameRules +defaultGameRules = GameRules + { _commandBlockOutput = True + , _doDaylightCycle = True + , _doFireTick = True + , _doMobLoot = True + , _doMobSpawning = True + , _doTileDrops = True + , _keepInventory = False + , _logAdminCommands = True + , _mobGriefing = True + , _naturalRegeneration = True + , _randomTickSpeed = 3 + , _sendCommandFeedback = True + , _showDeathMessages = True + , _reducedDebugInfo = False + } + +instance ToNBTContents GameRules where + toNBTContents gameRules = + CompoundTag + [ NBT "commandBlockOutput" (boolString $ _commandBlockOutput gameRules) + , NBT "doDaylightCycle" (boolString $ _doDaylightCycle gameRules) + , NBT "doFireTick" (boolString $ _doFireTick gameRules) + , NBT "doMobLoot" (boolString $ _doMobLoot gameRules) + , NBT "doMobSpawning" (boolString $ _doMobSpawning gameRules) + , NBT "doTileDrops" (boolString $ _doTileDrops gameRules) + , NBT "keepInventory" (boolString $ _keepInventory gameRules) + , NBT "logAdminCommands" (boolString $ _logAdminCommands gameRules) + , NBT "mobGriefing" (boolString $ _mobGriefing gameRules) + , NBT "naturalRegeneration" (boolString $ _naturalRegeneration gameRules) + , NBT "randomTickSpeed" (toNBTContents $ _randomTickSpeed gameRules) + , NBT "sendCommandFeedback" (boolString $ _sendCommandFeedback gameRules) + , NBT "showDeathMessages" (boolString $ _showDeathMessages gameRules) + , NBT "reducedDebugInfo" (boolString $ _reducedDebugInfo gameRules) + ] + where + boolString False = StringTag "false" + boolString True = StringTag "true" + +instance ToNBT GameRules where + toNBT gameRules = NBT "GameRules" (toNBTContents gameRules) + +data Version = Version + { _versionId :: Text + , _versionName :: Text + , _versionSnapshot :: Bool + } + +data Level = Level + { _version :: Int32 + , _initialized :: Bool + , _levelName :: Text + , _generatorName :: GeneratorName + , _generatorVersion :: Int32 -- ^ usually 0 + , _generatorOptions :: Text + , _randomSeed :: Int64 + , _mapFeatures :: Bool + , _lastPlayed :: POSIXTime + , _sizeOnDisk :: Int64 -- ^ currently unused + , _allowCommands :: Bool + , _hardcore :: Bool + , _gameType :: GameMode + , _difficulty :: Difficulty -- ^ default Normal + , _difficultyLocked :: Bool + , _time :: Int64 + , _dayTime :: Int64 + , _spawn :: XYZ + , _borderCenterX :: Double + , _borderCenterZ :: Double + , _borderSize :: Double -- ^ default 6.0e7 + , _borderSafeZone :: Double -- ^ default 5 + , _borderWarningBlocks :: Double -- ^ default 5 + , _borderWarningTime :: Double -- ^ default 15 + , _borderSizeLerpTarget :: Double -- ^ 6.0e7 + , _borderSizeLerpTime :: Int64 -- ^ default 0 + , _borderDamagePerBlock :: Double -- ^ default 0.2 + , _raining :: Bool + , _rainTime :: Int32 + , _thundering :: Bool + , _thunderTime :: Int32 + , _clearWeatherTime :: Int32 + , _player :: Player + } + +instance ToNBTContents Level where + toNBTContents level = CompoundTag + [ NBT "version" (toNBTContents (_version level)) + , NBT "initialized" (toNBTContents (_initialized level)) + , NBT "generatorName" (toNBTContents (_generatorName level)) + , NBT "generatorVersion" (toNBTContents (_generatorVersion level)) + , NBT "generatorOptions" (toNBTContents (_generatorOptions level)) + , NBT "RandomSeed" (toNBTContents (_randomSeed level)) + , NBT "MapFeatures" (toNBTContents (_mapFeatures level)) + , NBT "LastPlayed" (toNBTContents (_lastPlayed level)) + , NBT "SizeOnDisk" (toNBTContents (_sizeOnDisk level)) + , NBT "allowCommands" (toNBTContents (_allowCommands level)) + , NBT "hardcore" (toNBTContents (_hardcore level)) + , NBT "GameType" (toNBTContents (_gameType level)) + , NBT "Difficulty" (toNBTContents (_difficulty level)) + , NBT "DifficultyLocked" (toNBTContents (_difficultyLocked level)) + , NBT "Time" (toNBTContents (_time level)) + , NBT "DayTime" (toNBTContents (_dayTime level)) + , NBT "SpawnX" (toNBTContents (_x (_spawn level))) + , NBT "SpawnY" (toNBTContents (_y (_spawn level))) + , NBT "SpawnZ" (toNBTContents (_z (_spawn level))) + , NBT "BorderCenterX" (toNBTContents (_borderCenterX level)) + , NBT "BorderCenterZ" (toNBTContents (_borderCenterZ level)) + , NBT "BorderSize" (toNBTContents (_borderSize level)) + , NBT "BorderSafeZone" (toNBTContents (_borderSafeZone level)) + , NBT "BorderWarningBlocks" (toNBTContents (_borderWarningBlocks level)) + , NBT "BorderSizeLerpTarget" (toNBTContents (_borderSizeLerpTarget level)) + , NBT "BorderSizeLerpTime" (toNBTContents (_borderSizeLerpTime level)) + , NBT "BorderDamagePerBlock" (toNBTContents (_borderDamagePerBlock level)) + , NBT "raining" (toNBTContents (_raining level)) + , NBT "rainTime" (toNBTContents (_rainTime level)) + , NBT "thundering" (toNBTContents (_thundering level)) + , NBT "thunderTime" (toNBTContents (_thunderTime level)) + , NBT "clearWeatherTime" (toNBTContents (_clearWeatherTime level)) + , NBT "Player" (toNBTContents (_player level)) + ] + +instance ToNBT Level where + toNBT level = + NBT "" (CompoundTag [NBT "Data" (toNBTContents level)]) +defaultLevel :: Text -- ^ level name + -> Int64 -- ^ random seed + -> Int32 -- ^ XpSeed + -> Level +defaultLevel lvlName rSeed xpSeed = Level + { _version = 19133 + , _initialized = True + , _levelName = lvlName + , _generatorName = Default + , _generatorVersion = 0 + , _generatorOptions = "" + , _randomSeed = rSeed + , _mapFeatures = True + , _lastPlayed = 0 + , _sizeOnDisk = 0 + , _allowCommands = False + , _hardcore = False + , _gameType = SurvivalMode + , _difficulty = Normal + , _difficultyLocked = True + , _time = 0 + , _dayTime = sunrise + , _spawn = XYZ 0 0 0 + , _borderCenterX = 0.0 + , _borderCenterZ = 0.0 + , _borderSize = 6.0e7 + , _borderSafeZone = 5.0 + , _borderWarningBlocks = 5.0 + , _borderWarningTime = 15.0 + , _borderSizeLerpTarget = 6.0e7 + , _borderSizeLerpTime = 0 + , _borderDamagePerBlock = 0.2 + , _raining = False + , _rainTime = 0 + , _thundering = False + , _thunderTime = 0 + , _clearWeatherTime = 0 + , _player = defaultPlayer xpSeed + } diff --git a/Minecraft/Player.hs b/Minecraft/Player.hs new file mode 100644 --- /dev/null +++ b/Minecraft/Player.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +module Minecraft.Player where + +import Control.Lens.TH (makeLenses) +import Data.Data (Data) +import Data.Typeable (Typeable) +import Data.NBT +import Data.Int (Int8, Int16, Int32, Int64) +import Data.Text (Text) +import GHC.Generics (Generic) +import Minecraft.Core (Attribute(..), Dimension(..), Int6, Item(..), GameMode(..), ToNBT(..), ToNBTContents(..), XYZ(..)) +import TextShow (showt) + +data Abilities = Abilities + { _walkSpeed :: Float -- ^ 0.1 + , _flySpeed :: Float -- ^ 0.05 + , _mayFly :: Bool -- ^ true + , _flying :: Bool -- ^ false + , _invulnerable :: Bool -- ^ false + , _mayBuild :: Bool -- ^ true + , _instabuild :: Bool -- ^ false + } + deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) +makeLenses ''Abilities + +instance ToNBT Abilities where + toNBT abilities = + NBT "abilities" (toNBTContents abilities) + +instance ToNBTContents Abilities where + toNBTContents abilities = + (CompoundTag + [ NBT "walkSpeed" (FloatTag (_walkSpeed abilities)) + , NBT "flySpeed" (FloatTag (_flySpeed abilities)) + , NBT "mayfly" (toNBTContents (_mayFly abilities)) + , NBT "flying" (toNBTContents (_flying abilities)) + , NBT "invulnerable" (toNBTContents (_invulnerable abilities)) + , NBT "mayBuild" (toNBTContents (_mayBuild abilities)) + , NBT "instabuild" (toNBTContents (_instabuild abilities)) + ]) + +defaultAbilities :: Abilities +defaultAbilities = Abilities + { _walkSpeed = 0.1 + , _flySpeed = 0.05 + , _mayFly = True + , _flying = False + , _invulnerable = False + , _mayBuild = True + , _instabuild = False + } + +data InventoryItem = InventoryItem + { _slot :: Int6 + , _item :: Item + , _count :: Int6 + , _damage :: Int16 + } + deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) +makeLenses ''InventoryItem + +instance ToNBTContents InventoryItem where + toNBTContents ii = + CompoundTag [ NBT "Slot" (ByteTag (_slot ii)) + , NBT "id" (StringTag (showt (_item ii))) + , NBT "Count" (ByteTag (_count ii)) + , NBT "Damage" (ShortTag (_damage ii)) + ] + +data EnderItem = EnderItem + deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) + +instance ToNBTContents EnderItem where + toNBTContents EnderItem = error "ToNBTContents EnterItem not implemented." + +data Player = Player + { _dimension :: Dimension + , _playerGameType :: GameMode + , _score :: Int32 + , _selectedItemSlot :: Int32 + , _playerSpawn :: Maybe XYZ +-- , _spawnForced :: Bool + , _sleeping :: Bool + , _sleepTimer :: Int16 -- ^ 0, no effect + , _fire :: Int16 -- ^ -20 + , _foodLevel :: Int32 -- ^ 20 is full + , _foodExhaustionLevel :: Float -- ^ 0 + , _foodSaturationLevel :: Float -- ^ 5 + , _foodTickTimer :: Int32 -- ^ 0 + , _xpLevel :: Int32 -- ^ 0 + , _xpP :: Float -- ^ 0 + , _xpTotal :: Int32 -- ^ 0 + , _xpSeed :: Int32 + , _inventory :: [InventoryItem] + , _enderItems :: [EnderItem] + , _abilities :: Abilities + , _hurtByTimestamp :: Int32 -- ^ 0 + , _hurtTime :: Int16 -- ^ 0 + , _attributes :: [Attribute] + } + deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) +makeLenses ''Player + +instance ToNBT Player where + toNBT player = + NBT "Player" (toNBTContents player) + +instance ToNBTContents Player where + toNBTContents player = (CompoundTag + ((case _playerSpawn player of + Nothing -> [] + (Just (XYZ x y z)) -> + [ NBT "SpawnX" (toNBTContents x) + , NBT "SpawnY" (toNBTContents y) + , NBT "SpawnZ" (toNBTContents z) + ]) ++ + [ NBT "Dimension" (toNBTContents (_dimension player)) + , NBT "GameType" (toNBTContents (_playerGameType player)) + , NBT "Score" (toNBTContents (_score player)) + , NBT "SelectedItemSlot" (toNBTContents (_selectedItemSlot player)) + , NBT "Sleeping" (toNBTContents (_sleeping player)) + , NBT "SleepTimer" (toNBTContents (_sleepTimer player)) + , NBT "Fire" (toNBTContents (_fire player)) + , NBT "foodLevel" (toNBTContents (_foodLevel player)) + , NBT "foodExhaustionLevel" (toNBTContents (_foodExhaustionLevel player)) + , NBT "foodSaturationLevel" (toNBTContents (_foodSaturationLevel player)) + , NBT "foodTickTimer" (toNBTContents (_foodTickTimer player)) + , NBT "XpLevel" (toNBTContents (_xpLevel player)) + , NBT "XpP" (toNBTContents (_xpP player)) + , NBT "XpTotal" (toNBTContents (_xpTotal player)) + , NBT "Inventory" (toNBTContents (_inventory player)) + , NBT "EnderItems" (toNBTContents (_enderItems player)) + , toNBT (_abilities player) + , NBT "HurtByTimestamp" (toNBTContents (_hurtByTimestamp player)) + , NBT "HurtTime" (toNBTContents (_hurtTime player)) + , NBT "Attributes" (toNBTContents (_attributes player)) + ])) + +defaultPlayer :: Int32 -- ^ XpSeed + -> Player +defaultPlayer seed = Player + { _dimension = Overworld + , _playerGameType = SurvivalMode + , _score = 0 + , _selectedItemSlot = 0 + , _playerSpawn = Nothing + , _sleeping = False + , _sleepTimer = 0 + , _fire = (-20) + , _foodLevel = 20 + , _foodExhaustionLevel = 0 + , _foodSaturationLevel = 5 + , _foodTickTimer = 0 + , _xpLevel = 0 + , _xpP = 0 + , _xpTotal = 0 + , _xpSeed = seed + , _inventory = [] + , _enderItems = [] + , _abilities = defaultAbilities + , _hurtByTimestamp = 0 + , _hurtTime = 0 + , _attributes = [] + } diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/minecraft-data.cabal b/minecraft-data.cabal new file mode 100644 --- /dev/null +++ b/minecraft-data.cabal @@ -0,0 +1,46 @@ +name: minecraft-data +version: 0.1.0.0 +synopsis: a DSL for generating minecraft commands and levels +description: a DSL for generating minecraft commands and levels +homepage: https://github.com/stepcut/minecraft-data +license: BSD3 +license-file: LICENSE +author: jeremy@n-heptane.com +maintainer: jeremy@n-heptane.com +category: Game, Minecraft +build-type: Simple +cabal-version: >=1.10 +tested-with: GHC == 7.10.2, GHC==8.0.1 + +source-repository head + type: git + location: https://github.com/stepcut/minecraft-data.git + +library + exposed-modules: Minecraft.Anvil + Minecraft.Block + Minecraft.Chunk + Minecraft.Core + Minecraft.Command + Minecraft.Player + Minecraft.Level + other-extensions: DeriveDataTypeable, DeriveGeneric, OverloadedStrings + build-depends: array, + base >=4.8 && <4.10, + bytestring, + containers, + cereal, + pipes-bytestring, + pipes-cereal, + pipes-parse, + pipes-zlib, + pipes, + lens, + mtl, + nbt >= 0.6 && < 0.7, + text >=1.2 && <1.3, + text-show, + time, + vector, + zlib + default-language: Haskell2010