mirror of
https://github.com/urbit/shrub.git
synced 2024-12-21 18:01:32 +03:00
131 lines
3.7 KiB
Haskell
131 lines
3.7 KiB
Haskell
{-# 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
|