mirror of
https://github.com/urbit/shrub.git
synced 2025-01-02 01:25:55 +03:00
Remove Isle for now.
This commit is contained in:
Benjamin Summers
parent
b5919df50d
commit
3a99fe7834
@ -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
|
|
||||||
@ -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
|
|
||||||
Loading…
Reference in New Issue
Block a user