diff --git a/pkg/king/lib/Vere/Isle.hs b/pkg/king/lib/Vere/Isle.hs deleted file mode 100644 index bb23d63d7a..0000000000 --- a/pkg/king/lib/Vere/Isle.hs +++ /dev/null @@ -1,130 +0,0 @@ -{-# OPTIONS_GHC -Wwarn #-} - -module Vere.Isle where - -import ClassyPrelude -import Data.Word - -import qualified Data.Vector as V -import qualified SDL as SDL -import qualified Vere.Isle.Util as C - -import Data.Bits (testBit) -import Data.Vector ((!)) - --------------------------------------------------------------------------------- - -newtype Word4 = Word4 Word8 - deriving newtype (Eq, Ord, Num, Integral, Real, Enum) - -newtype Word10 = Word10 Word16 - deriving newtype (Eq, Ord, Num, Integral, Real, Enum) - -data RGB = RGB !Word8 !Word8 !Word8 - -type Bitmap = Word64 -- 8x8 bitmap - -{- - TODO Storable instance? - (Then I can use an unboxed vector) --} -data Tile = Tile - { tFore :: !Word4 - , tBack :: !Word4 - , tSpry :: !Word10 - } - -data Display = Display - { dColors :: V.Vector RGB -- size: 16 - , dSprites :: V.Vector Bitmap -- size: 1024 - , dTiles :: V.Vector Tile -- size: 3600 (80x45) - , dSurf :: V.Vector SDL.Surface -- size: 3600 (80x45) - } - -initializeSurfaces :: IO (V.Vector SDL.Surface) -initializeSurfaces = - V.generateM 3600 - $ const - $ SDL.createRGBSurface (SDL.V2 8 8) - $ SDL.RGB888 - -initialDisplay :: IO Display -initialDisplay = - do - surf <- initializeSurfaces - pure $ Display (V.generate 16 initialColors) - (V.generate 1024 initialSprites) - (V.generate 3600 initialTiles) - surf - where - initialSprites :: Int -> Bitmap - initialSprites = fromIntegral - - green = 4 - white = 15 - - initialTiles :: Int -> Tile - initialTiles i = - Tile green white (fromIntegral i `mod` 1024) - - initialColors :: Int -> RGB - initialColors = \case - 0 -> RGB 0x00 0x00 0x00 -- Black - 1 -> RGB 0x55 0x55 0x55 -- DarkGray - 2 -> RGB 0x00 0x00 0xAA -- Blue - 3 -> RGB 0x55 0x55 0xFF -- LightBlue - 4 -> RGB 0x00 0xAA 0x00 -- Green - 5 -> RGB 0x55 0xFF 0x55 -- LightGreen - 6 -> RGB 0x00 0xAA 0xAA -- Cyan - 7 -> RGB 0x55 0xFF 0xFF -- LightCyan - 8 -> RGB 0xAA 0x00 0x00 -- Red - 9 -> RGB 0xFF 0x55 0x55 -- LightRed - 10 -> RGB 0xAA 0x00 0xAA -- Magenta - 11 -> RGB 0xFF 0x55 0xFF -- LightMagenta - 12 -> RGB 0xAA 0x55 0x00 -- Brown - 13 -> RGB 0xFF 0xFF 0x55 -- Yellow - 14 -> RGB 0xAA 0xAA 0xAA -- LightGray - 15 -> RGB 0xFF 0xFF 0xFF -- White - n -> error ("bad color: " <> show n) - -renderTile :: Display -> Tile -> SDL.Surface -> IO () -renderTile d (Tile fg bg tx) surf = do - let for = dColors d ! fromIntegral fg - let bac = dColors d ! fromIntegral bg - let spry = dSprites d ! fromIntegral tx - for_ [0..63] $ \i -> do - let col = if testBit spry i then for else bac - renderPixel i surf col - -renderPixel :: Int -> SDL.Surface -> RGB -> IO () -renderPixel = undefined - - --- data Display = Display - {-dColors :: V.Vector RGB -- size: 16 - , dSprites :: V.Vector Bitmap -- size: 1024 - , dTiles :: V.Vector Tile -- size: 3600 (80x45) - , dSurf :: V.Vector SDL.Surface -- size: 3600 (80x45) - -} - -render :: Display -> IO () -render = undefined - -draw :: Display -> IO () -draw = undefined - --------------------------------------------------------------------------------- - -main :: IO () -main = C.withSDL $ C.withWindow "Lesson 01" (640, 480) $ - \w -> do - - screen <- SDL.getWindowSurface w - -- pixelFormat <- SDL.surfaceFormat `applyToPointer` screen - -- color <- SDL.mapRGB pixelFormat 0xFF 0xFF 0xFF - SDL.surfaceFillRect screen Nothing (SDL.V4 maxBound maxBound maxBound maxBound) - SDL.updateWindowSurface w - - SDL.delay 2000 - - SDL.freeSurface screen diff --git a/pkg/king/lib/Vere/Isle/Util.hs b/pkg/king/lib/Vere/Isle/Util.hs deleted file mode 100644 index f76d439e2f..0000000000 --- a/pkg/king/lib/Vere/Isle/Util.hs +++ /dev/null @@ -1,94 +0,0 @@ -module Vere.Isle.Util where - -import Prelude - -import Control.Monad (void) -import Control.Monad.IO.Class (MonadIO) -import Data.Text (Text) -import SDL (($=)) - -import qualified SDL -import qualified SDL.Image - --------------------------------------------------------------------------------- - -withSDL :: (MonadIO m) => m a -> m () -withSDL op = do - SDL.initialize [] - void op - SDL.quit - - -withSDLImage :: (MonadIO m) => m a -> m () -withSDLImage op = do - SDL.Image.initialize [] - void op - SDL.Image.quit - - -withWindow :: (MonadIO m) => Text -> (Int, Int) -> (SDL.Window -> m a) -> m () -withWindow title (x, y) op = do - w <- SDL.createWindow title p - SDL.showWindow w - void $ op w - SDL.destroyWindow w - - where - p = SDL.defaultWindow { SDL.windowInitialSize = z } - z = SDL.V2 (fromIntegral x) (fromIntegral y) - - -withRenderer :: (MonadIO m) => SDL.Window -> (SDL.Renderer -> m a) -> m () -withRenderer w op = do - r <- SDL.createRenderer w (-1) rendererConfig - void $ op r - SDL.destroyRenderer r - - -rendererConfig :: SDL.RendererConfig -rendererConfig = SDL.RendererConfig - { SDL.rendererType = SDL.AcceleratedVSyncRenderer - , SDL.rendererTargetTexture = False - } - - -renderSurfaceToWindow :: (MonadIO m) => SDL.Window -> SDL.Surface -> SDL.Surface -> m () -renderSurfaceToWindow w s i - = SDL.surfaceBlit i Nothing s Nothing - >> SDL.updateWindowSurface w - - -isContinue :: Maybe SDL.Event -> Bool -isContinue = maybe True (not . isQuitEvent) - - -conditionallyRun :: (Monad m) => m a -> Bool -> m Bool -conditionallyRun f True = True <$ f -conditionallyRun _ False = pure False - - -isQuitEvent :: SDL.Event -> Bool -isQuitEvent (SDL.Event _t SDL.QuitEvent) = True -isQuitEvent _ = False - - -setHintQuality :: (MonadIO m) => m () -setHintQuality = SDL.HintRenderScaleQuality $= SDL.ScaleNearest - - -loadTextureWithInfo :: (MonadIO m) => SDL.Renderer -> FilePath -> m (SDL.Texture, SDL.TextureInfo) -loadTextureWithInfo r p = do - t <- SDL.Image.loadTexture r p - i <- SDL.queryTexture t - pure (t, i) - - -mkPoint :: a -> a -> SDL.Point SDL.V2 a -mkPoint x y = SDL.P (SDL.V2 x y) - - -mkRect :: a -> a -> a -> a-> SDL.Rectangle a -mkRect x y w h = SDL.Rectangle o z - where - o = SDL.P (SDL.V2 x y) - z = SDL.V2 w h