mirror of
https://github.com/ilyakooo0/urbit.git
synced 2024-12-01 20:04:09 +03:00
Whatever
This commit is contained in:
Benjamin Summers
parent
3e518f4d99
commit
3fd0ab4270
2
pkg/hs-conq/.gitignore
vendored
Normal file
2
pkg/hs-conq/.gitignore
vendored
Normal file
@ -0,0 +1,2 @@
|
||||
.stack-work
|
||||
*.cabal
|
||||
455
pkg/hs-conq/lib/Language/Conq.hs
Normal file
455
pkg/hs-conq/lib/Language/Conq.hs
Normal file
@ -0,0 +1,455 @@
|
||||
module Language.Conq where
|
||||
|
||||
import ClassyPrelude hiding (pure, (<.>), Left, Right)
|
||||
import Data.Type.Equality
|
||||
import Type.Reflection
|
||||
import Data.Coerce
|
||||
import GHC.Natural
|
||||
import Control.Category
|
||||
|
||||
import Data.Bits ((.|.), shiftL, shiftR)
|
||||
import Text.Show (showString, showParen)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
type Tup a b = (a, b)
|
||||
data Sum a b = L a | R b
|
||||
deriving (Eq, Ord)
|
||||
|
||||
instance (Show a, Show b) => Show (Sum a b) where
|
||||
show (L x) = case show x of { "()" → "L"; xs → "L" <> xs }
|
||||
show (R x) = case show x of { "()" → "R"; xs → "R" <> xs }
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data Lit
|
||||
= Nil
|
||||
| LTup Lit Lit
|
||||
| LLef Lit
|
||||
| LRit Lit
|
||||
deriving (Eq, Ord)
|
||||
|
||||
instance Show Lit where
|
||||
show = \case
|
||||
Nil -> "~"
|
||||
LTup x y -> "[" <> show x <> " " <> show y <> "]"
|
||||
LLef Nil -> "1"
|
||||
LRit Nil -> "0"
|
||||
LLef l -> "<l " <> show l <> ">"
|
||||
LRit r -> "<r " <> show r <> ">"
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
class ToLit a where
|
||||
toLit :: a -> Lit
|
||||
|
||||
instance ToLit () where
|
||||
toLit () = Nil
|
||||
|
||||
instance (ToLit a, ToLit b) => ToLit (Sum a b) where
|
||||
toLit (L l) = LLef (toLit l)
|
||||
toLit (R r) = LRit (toLit r)
|
||||
|
||||
instance (ToLit a, ToLit b) => ToLit (Tup a b) where
|
||||
toLit (l, r) = LTup (toLit l) (toLit r)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data Exp
|
||||
= ESubj
|
||||
| ENull
|
||||
| EEval
|
||||
| ELeft
|
||||
| EWrit
|
||||
| EHead
|
||||
| ETail
|
||||
| EDist
|
||||
| EWith Exp Exp
|
||||
| ECons Exp Exp
|
||||
| ECase Exp Exp
|
||||
deriving (Eq, Ord)
|
||||
|
||||
instance Show Exp where
|
||||
showsPrec d = \case
|
||||
ESubj -> showString "."
|
||||
ENull -> showString "~"
|
||||
EEval -> showString "!"
|
||||
ELeft -> showString "L"
|
||||
EWrit -> showString "R"
|
||||
EHead -> showString "-"
|
||||
ETail -> showString "+"
|
||||
EDist -> showString "%"
|
||||
EWith x y -> showsPrec d x . showsPrec d y
|
||||
ECons x y -> showString "["
|
||||
. showsPrec d x
|
||||
. showString " "
|
||||
. showsPrec d y
|
||||
. showString "]"
|
||||
ECase x y -> showString "<"
|
||||
. showsPrec d x
|
||||
. showString " "
|
||||
. showsPrec d y
|
||||
. showString ">"
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
class ToConq a s r where
|
||||
toConq :: a -> Conq s r
|
||||
|
||||
instance ToConq (Conq s a, Conq a r) s r where
|
||||
toConq (x,y) = With x y
|
||||
|
||||
instance ToConq (Conq s a, Conq a b, Conq b r) s r where
|
||||
toConq (x,y,z) = With (toConq (x,y)) z
|
||||
|
||||
instance ToConq (Conq s a, Conq a b, Conq b c, Conq c r) s r where
|
||||
toConq (x,y,z,p) = With (toConq (x,y,z)) p
|
||||
|
||||
instance ToConq (Conq s a, Conq a b, Conq b c, Conq c d, Conq d r) s r where
|
||||
toConq (x,y,z,p,q) = With (toConq (x,y,z,p)) q
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data Conq s r where
|
||||
Subj :: Conq s s
|
||||
Null :: Conq s ()
|
||||
Left :: Conq a (Sum a b)
|
||||
Writ :: Conq b (Sum a b)
|
||||
Head :: Conq (Tup a b) a
|
||||
Tail :: Conq (Tup a b) b
|
||||
Cons :: Conq s a -> Conq s b -> Conq s (a, b)
|
||||
Kase :: Conq a r -> Conq b r -> Conq (Sum a b) r
|
||||
Dist :: Conq (Sum a b,s) (Sum (a,s) (b,s))
|
||||
With :: Conq s a -> Conq a r -> Conq s r
|
||||
Eval :: Conq (a, Conq a r) r
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
-- Case :: Conq (a,s) r -> Conq (b,s) r -> Conq (Sum a b,s) r
|
||||
|
||||
instance Category Conq where
|
||||
id = Subj
|
||||
(.) = flip With
|
||||
|
||||
instance Show (Conq s r) where
|
||||
show c = show (toExp c)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
run :: s -> Conq s r -> r
|
||||
run sut = \case
|
||||
Null -> ()
|
||||
Subj -> sut
|
||||
With x y -> run (run sut x) y
|
||||
Eval -> case sut of (s,f) -> run s f
|
||||
Cons x y -> (run sut x, run sut y)
|
||||
Left -> L sut
|
||||
Writ -> R sut
|
||||
Head -> fst sut
|
||||
Tail -> snd sut
|
||||
Dist -> case sut of { (L l,x) -> L (l,x); (R r,x) -> R (r,x); }
|
||||
Kase p q -> case sut of { L l -> run l p; R r -> run r q; }
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
--Case p q -> case sut of (L l,x) -> run (l,x) p
|
||||
-- (R r,x) -> run (r,x) q
|
||||
|
||||
times :: Int -> Conq s s -> Conq s s
|
||||
times 0 _ = id
|
||||
times 1 f = f
|
||||
times n f = With f (times (n-1) f)
|
||||
|
||||
runTimes :: Int -> s -> Conq s s -> s
|
||||
runTimes n sut conq = go n
|
||||
where
|
||||
go 0 = sut
|
||||
go 1 = run sut conq
|
||||
go n = run (go (n-1)) conq
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
toExp :: Conq s r -> Exp
|
||||
toExp = \case
|
||||
Subj -> ESubj
|
||||
Null -> ENull
|
||||
Eval -> EEval
|
||||
Left -> ELeft
|
||||
Writ -> EWrit
|
||||
Head -> EHead
|
||||
Tail -> ETail
|
||||
Dist -> EDist
|
||||
Cons x y -> ECons (toExp x) (toExp y)
|
||||
--Case l r -> ECase (toExp l) (toExp r)
|
||||
Kase l r -> ECase (toExp l) (toExp r)
|
||||
With x y -> EWith (toExp x) (toExp y)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
fromExp :: forall s r. (Typeable s, Typeable r) => Exp -> Maybe (Conq s r)
|
||||
fromExp = \case
|
||||
ESubj ->
|
||||
case testEquality (typeRep @s) (typeRep @r) of
|
||||
Just Refl -> Just (coerce Subj)
|
||||
Nothing -> Nothing
|
||||
|
||||
_ ->
|
||||
Nothing
|
||||
|
||||
-- Axis Lookup -----------------------------------------------------------------
|
||||
|
||||
a1 :: Conq a a
|
||||
a1 = Subj
|
||||
|
||||
a2 :: Conq (Tup a b) a
|
||||
a2 = Head
|
||||
|
||||
a3 :: Conq (Tup a b) b
|
||||
a3 = Tail
|
||||
|
||||
a4 :: Conq (Tup (Tup a b) c) a
|
||||
a4 = Head . Head
|
||||
|
||||
a5 :: Conq (Tup (Tup a b) c) b
|
||||
a5 = Tail . Head
|
||||
|
||||
a6 :: Conq (Tup a (Tup b c)) b
|
||||
a6 = Head . Tail
|
||||
|
||||
a7 :: Conq (Tup a (Tup b c)) c
|
||||
a7 = Tail . Tail
|
||||
|
||||
a8 :: Conq (((a, b), c), d) a
|
||||
a8 = Head . Head . Head
|
||||
|
||||
|
||||
-- Eat Operations --------------------------------------------------------------
|
||||
|
||||
nothing :: Conq s (Sum () a)
|
||||
nothing = Left . Null
|
||||
|
||||
just :: Conq a (Sum () a)
|
||||
just = Writ
|
||||
|
||||
case' :: Conq (a,s) r -> Conq (b,s) r -> Conq (Sum a b,s) r
|
||||
case' x y = Kase x y . Dist
|
||||
|
||||
previewLeft :: Conq (Sum a b) (Sum () a)
|
||||
previewLeft = Kase just nothing
|
||||
|
||||
previewWrit :: Conq (Sum a b) (Sum () b)
|
||||
previewWrit = Kase nothing just
|
||||
|
||||
|
||||
-- Pair Operations -------------------------------------------------------------
|
||||
|
||||
curry' :: Conq (a, b) c -> Conq s a -> Conq s b -> Conq s c
|
||||
curry' f x y = With (Cons x y) f
|
||||
|
||||
both :: Conq a b -> Conq (a, a) (b, b)
|
||||
both x = Cons (With Head x) (With Tail x)
|
||||
|
||||
dub_equal :: Conq (a, a) Bit -> Conq ((a, a), (a, a)) Bit
|
||||
dub_equal cmp = With results and'
|
||||
where
|
||||
results = Cons (With (both Head) cmp) (With (both Tail) cmp)
|
||||
|
||||
dub_test :: Conq a Bit -> Conq (a, a) Bit
|
||||
dub_test test = curry' and' (With Head test) (With Tail test)
|
||||
|
||||
dub_inc :: Conq a a -> Conq a Bit -> Conq (a, a) (a, a)
|
||||
dub_inc inc null = With bump_low (if' low_zero bump_hig id)
|
||||
where
|
||||
bump_low = Cons (With Head inc) Tail
|
||||
bump_hig = Cons Head (With Tail inc)
|
||||
low_zero = With Head null
|
||||
|
||||
bit :: Int -> Bit
|
||||
bit n = runTimes n val_bit_zero bit_inc
|
||||
|
||||
|
||||
-- Boolean Operations ----------------------------------------------------------
|
||||
|
||||
type Bit = Sum () ()
|
||||
|
||||
true :: Conq s Bit
|
||||
true = Writ . Null
|
||||
|
||||
false :: Conq s Bit
|
||||
false = Left . Null
|
||||
|
||||
not' :: Conq Bit Bit
|
||||
not' = Kase Writ Left
|
||||
|
||||
id' :: Conq Bit Bit
|
||||
id' = Kase Writ Left
|
||||
|
||||
dup :: Conq a (a, a)
|
||||
dup = Cons Subj Subj
|
||||
|
||||
if' :: Conq s Bit -> Conq s r -> Conq s r -> Conq s r
|
||||
if' c t f = case' (With Tail f) (With Tail t) . Cons c Subj
|
||||
|
||||
and' :: Conq (Bit, Bit) Bit
|
||||
and' = if' a2 a3 false
|
||||
|
||||
or' :: Conq (Bit, Bit) Bit
|
||||
or' = if' a2 true a3
|
||||
|
||||
xor' :: Conq (Bit, Bit) Bit
|
||||
xor' = if' a2 (With a3 not') a3
|
||||
|
||||
bit_eq :: Conq (Bit, Bit) Bit
|
||||
bit_eq = if' a2 a3 (With a3 not')
|
||||
|
||||
bit_zero :: Conq s Bit
|
||||
bit_zero = false
|
||||
|
||||
val_bit_zero :: Bit
|
||||
val_bit_zero = run () bit_zero
|
||||
|
||||
bit_is_zero :: Conq Bit Bit
|
||||
bit_is_zero = not'
|
||||
|
||||
bit_inc :: Conq Bit Bit
|
||||
bit_inc = not'
|
||||
|
||||
-- Duo Operations (2 bit) ------------------------------------------------------
|
||||
|
||||
type Duo = (Bit, Bit)
|
||||
|
||||
duo_zero :: Conq s Duo
|
||||
duo_zero = Cons bit_zero bit_zero
|
||||
|
||||
duo_is_zero :: Conq Duo Bit
|
||||
duo_is_zero = dub_test bit_is_zero
|
||||
|
||||
duo_inc :: Conq Duo Duo
|
||||
duo_inc = Kase (Cons true Tail) (Cons false (not' . Tail)) . Dist
|
||||
|
||||
factor :: Conq (Sum (a, c) (b, c)) (Sum a b, c)
|
||||
factor = Kase (Cons (Left . Head) Tail)
|
||||
(Cons (Writ . Head) Tail)
|
||||
|
||||
duo :: Int -> Duo
|
||||
duo n = runTimes n (run () duo_zero) duo_inc
|
||||
|
||||
duo_equal :: Conq (Duo, Duo) Bit
|
||||
duo_equal = dub_equal bit_eq
|
||||
|
||||
|
||||
-- Nibble Operations (4 bit) ---------------------------------------------------
|
||||
|
||||
type Nyb = (Duo, Duo)
|
||||
|
||||
nyb_zero :: Conq a Nyb
|
||||
nyb_zero = Cons duo_zero duo_zero
|
||||
|
||||
nyb_is_zero :: Conq Nyb Bit
|
||||
nyb_is_zero = dub_test duo_is_zero
|
||||
|
||||
nyb_inc :: Conq Nyb Nyb
|
||||
nyb_inc = dub_inc duo_inc duo_is_zero
|
||||
|
||||
nyb :: Int -> Nyb
|
||||
nyb n = runTimes n (run () nyb_zero) nyb_inc
|
||||
|
||||
nyb_equal :: Conq (Nyb, Nyb) Bit
|
||||
nyb_equal = dub_equal duo_equal
|
||||
|
||||
|
||||
-- Byte Operations (8 bit) -----------------------------------------------------
|
||||
|
||||
type Byt = (Nyb, Nyb)
|
||||
|
||||
byt_zero :: Conq a Byt
|
||||
byt_zero = Cons nyb_zero nyb_zero
|
||||
|
||||
byt_is_zero :: Conq Byt Bit
|
||||
byt_is_zero = dub_test nyb_is_zero
|
||||
|
||||
byt_inc :: Conq Byt Byt
|
||||
byt_inc = dub_inc nyb_inc nyb_is_zero
|
||||
|
||||
byt :: Int -> Byt
|
||||
byt n = runTimes n (run () byt_zero) byt_inc
|
||||
|
||||
byt_equal :: Conq (Byt, Byt) Bit
|
||||
byt_equal = dub_equal nyb_equal
|
||||
|
||||
|
||||
-- Short Operations (16 bit) ---------------------------------------------------
|
||||
|
||||
type Short = (Byt, Byt)
|
||||
|
||||
short_zero :: Conq a Short
|
||||
short_zero = Cons byt_zero byt_zero
|
||||
|
||||
short_is_zero :: Conq Short Bit
|
||||
short_is_zero = dub_test byt_is_zero
|
||||
|
||||
short_inc :: Conq Short Short
|
||||
short_inc = dub_inc byt_inc byt_is_zero
|
||||
|
||||
short :: Int -> Short
|
||||
short n = runTimes n (run () short_zero) short_inc
|
||||
|
||||
short_equal :: Conq (Short, Short) Bit
|
||||
short_equal = dub_equal byt_equal
|
||||
|
||||
|
||||
-- Wide Operations (32 bit) ----------------------------------------------------
|
||||
|
||||
type Wide = (Short, Short)
|
||||
|
||||
wide_zero :: Conq a Wide
|
||||
wide_zero = Cons short_zero short_zero
|
||||
|
||||
wide_is_zero :: Conq Wide Bit
|
||||
wide_is_zero = dub_test short_is_zero
|
||||
|
||||
wide_inc :: Conq Wide Wide
|
||||
wide_inc = dub_inc short_inc short_is_zero
|
||||
|
||||
wide :: Int -> Wide
|
||||
wide n = runTimes n (run () wide_zero) wide_inc
|
||||
|
||||
wide_equal :: Conq (Wide, Wide) Bit
|
||||
wide_equal = dub_equal short_equal
|
||||
|
||||
|
||||
-- Long Operations (64 bit) ----------------------------------------------------
|
||||
|
||||
type Long = (Wide, Wide)
|
||||
|
||||
long_zero :: Conq a Long
|
||||
long_zero = Cons wide_zero wide_zero
|
||||
|
||||
long_is_zero :: Conq Long Bit
|
||||
long_is_zero = dub_test wide_is_zero
|
||||
|
||||
long_inc :: Conq Long Long
|
||||
long_inc = dub_inc wide_inc wide_is_zero
|
||||
|
||||
long :: Int -> Long
|
||||
long n = runTimes n (run () long_zero) long_inc
|
||||
|
||||
long_equal :: Conq (Long, Long) Bit
|
||||
long_equal = dub_equal wide_equal
|
||||
|
||||
n0 :: Conq a (Sum () a)
|
||||
n0 = Left . Null
|
||||
|
||||
n1 :: Conq a (Sum () (Sum () a))
|
||||
n1 = Writ . n0
|
||||
|
||||
n2 :: Conq a (Sum () (Sum () (Sum () a)))
|
||||
n2 = Writ . n1
|
||||
80
pkg/hs-conq/package.yaml
Normal file
80
pkg/hs-conq/package.yaml
Normal file
@ -0,0 +1,80 @@
|
||||
name: language-conq
|
||||
version: 0.1.0
|
||||
license: AGPL-3.0-only
|
||||
|
||||
library:
|
||||
source-dirs: lib
|
||||
ghc-options:
|
||||
- -fwarn-incomplete-patterns
|
||||
- -O2
|
||||
|
||||
dependencies:
|
||||
- async
|
||||
- base
|
||||
- case-insensitive
|
||||
- chunked-data
|
||||
- classy-prelude
|
||||
- containers
|
||||
- data-fix
|
||||
- extra
|
||||
- flat
|
||||
- ghc-prim
|
||||
- http-client
|
||||
- http-types
|
||||
- integer-gmp
|
||||
- largeword
|
||||
- lens
|
||||
- megaparsec
|
||||
- mtl
|
||||
- multimap
|
||||
- para
|
||||
- pretty-show
|
||||
- QuickCheck
|
||||
- semigroups
|
||||
- smallcheck
|
||||
- stm
|
||||
- stm-chans
|
||||
- tasty
|
||||
- tasty-quickcheck
|
||||
- tasty-th
|
||||
- text
|
||||
- these
|
||||
- time
|
||||
- transformers
|
||||
- unordered-containers
|
||||
- vector
|
||||
|
||||
default-extensions:
|
||||
- ApplicativeDo
|
||||
- BangPatterns
|
||||
- BlockArguments
|
||||
- DeriveAnyClass
|
||||
- DeriveDataTypeable
|
||||
- DeriveFoldable
|
||||
- DeriveGeneric
|
||||
- DeriveTraversable
|
||||
- DerivingStrategies
|
||||
- EmptyDataDecls
|
||||
- FlexibleContexts
|
||||
- FlexibleInstances
|
||||
- FunctionalDependencies
|
||||
- GADTs
|
||||
- GeneralizedNewtypeDeriving
|
||||
- LambdaCase
|
||||
- MultiParamTypeClasses
|
||||
- NamedFieldPuns
|
||||
- NoImplicitPrelude
|
||||
- NumericUnderscores
|
||||
- OverloadedStrings
|
||||
- PartialTypeSignatures
|
||||
- QuasiQuotes
|
||||
- Rank2Types
|
||||
- RankNTypes
|
||||
- RecordWildCards
|
||||
- ScopedTypeVariables
|
||||
- TemplateHaskell
|
||||
- TupleSections
|
||||
- TypeApplications
|
||||
- TypeFamilies
|
||||
- UnicodeSyntax
|
||||
- ViewPatterns
|
||||
@ -1,49 +1,116 @@
|
||||
module Vere.Isle where
|
||||
|
||||
import ClassyPrelude
|
||||
import Data.Word
|
||||
|
||||
import qualified Vere.Isle.Util as C
|
||||
import qualified SDL as SDL
|
||||
import qualified Data.Vector as V
|
||||
|
||||
import Data.Flat (Flat)
|
||||
import Data.Bits (testBit)
|
||||
import Data.Vector ((!))
|
||||
import Data.Flat (Flat)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data Color
|
||||
= Black | DarkGray
|
||||
| Blue | LightBlue
|
||||
| Green | LightGreen
|
||||
| Cyan | LightCyan
|
||||
| Red | LightRed
|
||||
| Magenta | LightMagenta
|
||||
| Brown | Yellow
|
||||
| LightGray | White
|
||||
deriving stock (Eq, Ord, Show, Enum, Bounded, Generic)
|
||||
deriving anyclass Flat
|
||||
newtype Word4 = Word4 Word8
|
||||
deriving newtype (Eq, Ord, Num, Integral, Real, Enum)
|
||||
|
||||
type Blit = Vector (Vector Color)
|
||||
newtype Word10 = Word10 Word16
|
||||
deriving newtype (Eq, Ord, Num, Integral, Real, Enum)
|
||||
|
||||
solid :: Color -> Blit
|
||||
solid c = replicate 640 (replicate 480 c)
|
||||
data RGB = RGB !Word8 !Word8 !Word8
|
||||
|
||||
toRGB :: Color -> (Word8, Word8, Word8)
|
||||
toRGB = \case
|
||||
Black -> (0x00, 0x00, 0x00)
|
||||
DarkGray -> (0x55, 0x55, 0x55)
|
||||
Blue -> (0x00, 0x00, 0xAA)
|
||||
LightBlue -> (0x55, 0x55, 0xFF)
|
||||
Green -> (0x00, 0xAA, 0x00)
|
||||
LightGreen -> (0x55, 0xFF, 0x55)
|
||||
Cyan -> (0x00, 0xAA, 0xAA)
|
||||
LightCyan -> (0x55, 0xFF, 0xFF)
|
||||
Red -> (0xAA, 0x00, 0x00)
|
||||
LightRed -> (0xFF, 0x55, 0x55)
|
||||
Magenta -> (0xAA, 0x00, 0xAA)
|
||||
LightMagenta -> (0xFF, 0x55, 0xFF)
|
||||
Brown -> (0xAA, 0x55, 0x00)
|
||||
Yellow -> (0xFF, 0xFF, 0x55)
|
||||
LightGray -> (0xAA, 0xAA, 0xAA)
|
||||
White -> (0xFF, 0xFF, 0xFF)
|
||||
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
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
||||
@ -17,6 +17,7 @@ dependencies:
|
||||
- containers
|
||||
- data-fix
|
||||
- extra
|
||||
- fixed-vector
|
||||
- flat
|
||||
- ghc-prim
|
||||
- hashtables
|
||||
@ -55,6 +56,7 @@ dependencies:
|
||||
|
||||
default-extensions:
|
||||
- ApplicativeDo
|
||||
- DataKinds
|
||||
- BangPatterns
|
||||
- BlockArguments
|
||||
- DeriveAnyClass
|
||||
|
||||
@ -4,11 +4,20 @@ packages:
|
||||
- pkg/hs-urbit
|
||||
- pkg/hs-vere
|
||||
- pkg/hs-hoon
|
||||
- pkg/hs-conq
|
||||
|
||||
extra-deps:
|
||||
- para-1.1@sha256:a90eebb063ad70271e6e2a7f00a93e8e8f8b77273f100f39852fbf8301926f81
|
||||
- flat-0.3.4@sha256:002a0e0ae656ea8cc02a772d0bcb6ea7dbd7f2e79070959cc748ad1e7138eb38
|
||||
|
||||
nix:
|
||||
packages:
|
||||
- pkgconfig
|
||||
- SDL2
|
||||
- SDL2_image
|
||||
- zlib
|
||||
|
||||
|
||||
# build:
|
||||
# library-profiling: true
|
||||
# executable-profiling: true
|
||||
|
||||
Loading…
Reference in New Issue
Block a user