brillo-examples 2.0.1 → 2.1.0
raw patch · 4 files changed
+919/−50 lines, 4 filesdep +bytestringdep ~brillodep ~brillo-algorithmsdep ~brillo-exportnew-component:exe:brillo-compressed-bitmapnew-component:exe:brillo-shadernew-component:exe:brillo-spaceinvaders
Dependencies added: bytestring
Dependency ranges changed: brillo, brillo-algorithms, brillo-export, brillo-rendering
Files
- brillo-examples.cabal +84/−50
- picture/CompressedBitmap/Main.hs +219/−0
- picture/Shader/Main.hs +97/−0
- picture/SpaceInvaders/Main.hs +519/−0
brillo-examples.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: brillo-examples-version: 2.0.1+version: 2.1.0 license: MIT license-file: LICENSE author: Ben Lippmeier, Adrian Sieber@@ -33,7 +33,7 @@ hs-source-dirs: picture/Antialiasing build-depends: , base >=4.8 && <5- , brillo >=2.0 && <3.0+ , brillo >=3.0 && <4.0 ghc-options: -O2 -Wall -threaded -rtsopts @@ -43,7 +43,7 @@ hs-source-dirs: picture/CircleComparison build-depends: , base >=4.8 && <5- , brillo >=2.0 && <3.0+ , brillo >=3.0 && <4.0 , text >=2.0 && <2.2 ghc-options: -O2 -Wall -threaded -rtsopts@@ -54,11 +54,23 @@ hs-source-dirs: picture/Bitmap build-depends: , base >=4.8 && <5- , brillo >=2.0 && <3.0+ , brillo >=3.0 && <4.0 , text >=2.0 && <2.2 ghc-options: -O2 -Wall -threaded -rtsopts +executable brillo-compressed-bitmap+ default-language: GHC2021+ main-is: Main.hs+ hs-source-dirs: picture/CompressedBitmap+ build-depends:+ , base >=4.8 && <5+ , brillo >=3.0 && <4.0+ , bytestring >=0.11 && <0.13+ , text >=2.0 && <2.2++ ghc-options: -O2 -Wall -threaded -rtsopts+ executable brillo-boids default-language: GHC2021 main-is: Main.hs@@ -69,7 +81,7 @@ build-depends: , base >=4.8 && <5- , brillo >=2.0 && <3.0+ , brillo >=3.0 && <4.0 , random >=1.2 && <1.3 ghc-options: -O2 -threaded -rtsopts@@ -80,7 +92,7 @@ hs-source-dirs: picture/Clock build-depends: , base >=4.8 && <5- , brillo >=2.0 && <3.0+ , brillo >=3.0 && <4.0 , text >=2.0 && <2.2 ghc-options: -O2 -Wall -threaded -rtsopts@@ -91,7 +103,7 @@ hs-source-dirs: picture/Color build-depends: , base >=4.8 && <5- , brillo >=2.0 && <3.0+ , brillo >=3.0 && <4.0 ghc-options: -O2 -Wall -threaded -rtsopts @@ -105,7 +117,7 @@ build-depends: , base >=4.8 && <5- , brillo >=2.0 && <3.0+ , brillo >=3.0 && <4.0 , random >=1.2 && <1.3 , vector >=0.13 && <0.14 @@ -117,7 +129,7 @@ hs-source-dirs: picture/Draw build-depends: , base >=4.8 && <5- , brillo >=2.0 && <3.0+ , brillo >=3.0 && <4.0 ghc-options: -O2 -Wall -threaded -rtsopts @@ -127,7 +139,7 @@ hs-source-dirs: picture/DropFiles build-depends: , base >=4.8 && <5- , brillo >=2.0 && <3.0+ , brillo >=3.0 && <4.0 , text >=2.0 && <2.2 ghc-options: -O2 -Wall -threaded -rtsopts@@ -138,7 +150,7 @@ hs-source-dirs: picture/Easy build-depends: , base >=4.8 && <5- , brillo >=2.0 && <3.0+ , brillo >=3.0 && <4.0 ghc-options: -O2 -Wall -threaded -rtsopts @@ -153,7 +165,7 @@ build-depends: , base >=4.8 && <5- , brillo >=2.0 && <3.0+ , brillo >=3.0 && <4.0 , random >=1.2 && <1.3 ghc-options: -O2 -Wall -threaded -rtsopts@@ -164,7 +176,7 @@ hs-source-dirs: picture/Flake build-depends: , base >=4.8 && <5- , brillo >=2.0 && <3.0+ , brillo >=3.0 && <4.0 ghc-options: -O2 -Wall -threaded -rtsopts @@ -174,7 +186,7 @@ hs-source-dirs: picture/GameEvent build-depends: , base >=4.8 && <5- , brillo >=2.0 && <3.0+ , brillo >=3.0 && <4.0 , text >=2.0 && <2.2 ghc-options: -O2 -Wall -threaded -rtsopts@@ -185,7 +197,7 @@ hs-source-dirs: picture/Interaction build-depends: , base >=4.8 && <5- , brillo >=2.0 && <3.0+ , brillo >=3.0 && <4.0 , text >=2.0 && <2.2 ghc-options: -O2 -Wall -threaded -rtsopts@@ -196,7 +208,7 @@ hs-source-dirs: picture/Hello build-depends: , base >=4.8 && <5- , brillo >=2.0 && <3.0+ , brillo >=3.0 && <4.0 ghc-options: -O2 -Wall -threaded -rtsopts @@ -211,7 +223,7 @@ build-depends: , base >=4.8 && <5- , brillo >=2.0 && <3.0+ , brillo >=3.0 && <4.0 , random >=1.2 && <1.3 ghc-options: -O2 -Wall -threaded -rtsopts@@ -222,7 +234,7 @@ hs-source-dirs: picture/Lines build-depends: , base >=4.8 && <5- , brillo >=2.0 && <3.0+ , brillo >=3.0 && <4.0 ghc-options: -O2 -Wall -threaded -rtsopts @@ -232,7 +244,7 @@ hs-source-dirs: picture/Machina build-depends: , base >=4.8 && <5- , brillo >=2.0 && <3.0+ , brillo >=3.0 && <4.0 ghc-options: -O2 -Wall -threaded -rtsopts @@ -247,9 +259,9 @@ World build-depends:- , base >=4.8 && <5- , brillo >=2.0 && <3.0- , brillo-algorithms >=2.0 && <3.0+ , base >=4.8 && <5+ , brillo >=3.0 && <4.0+ , brillo-algorithms >=2.0.1 && <3.0 ghc-options: -O2 -threaded -rtsopts @@ -259,7 +271,7 @@ hs-source-dirs: picture/PickFiles build-depends: , base >=4.8 && <5- , brillo >=2.0 && <3.0+ , brillo >=3.0 && <4.0 , text >=2.0 && <2.2 ghc-options: -O2 -Wall -threaded -rtsopts@@ -270,7 +282,7 @@ hs-source-dirs: picture/Polygons build-depends: , base >=4.8 && <5- , brillo >=2.0 && <3.0+ , brillo >=3.0 && <4.0 ghc-options: -O2 -Wall -threaded -rtsopts @@ -289,7 +301,7 @@ build-depends: , base >=4.8 && <5- , brillo >=2.0 && <3.0+ , brillo >=3.0 && <4.0 , containers >=0.5 && <0.9 ghc-options: -O2 -Wall -threaded -rtsopts@@ -300,7 +312,7 @@ hs-source-dirs: picture/Tree build-depends: , base >=4.8 && <5- , brillo >=2.0 && <3.0+ , brillo >=3.0 && <4.0 ghc-options: -O2 -Wall -threaded -rtsopts @@ -318,7 +330,7 @@ build-depends: , base >=4.8 && <5- , brillo >=2.0 && <3.0+ , brillo >=3.0 && <4.0 , vector >=0.13 && <0.14 ghc-options: -O2 -Wall -threaded -rtsopts@@ -329,7 +341,7 @@ hs-source-dirs: picture/Zen build-depends: , base >=4.8 && <5- , brillo >=2.0 && <3.0+ , brillo >=3.0 && <4.0 ghc-options: -O2 -Wall -threaded -rtsopts @@ -339,7 +351,7 @@ hs-source-dirs: picture/Graph build-depends: , base >=4.8 && <5- , brillo >=2.0 && <3.0+ , brillo >=3.0 && <4.0 , containers >=0.5 && <0.9 , random >=1.2 && <1.3 @@ -351,7 +363,7 @@ hs-source-dirs: picture/Gravity build-depends: , base >=4.8 && <5- , brillo >=2.0 && <3.0+ , brillo >=3.0 && <4.0 , random >=1.2 && <1.3 ghc-options: -O2 -Wall -threaded -rtsopts@@ -360,8 +372,8 @@ default-language: GHC2021 build-depends: , base >=4.8 && <5- , brillo >=2.0 && <3.0- , brillo-rendering >=2.0 && <3.0+ , brillo >=3.0 && <4.0+ , brillo-rendering >=3.0 && <4.0 , GLFW-b >=3.3 && <4 main-is: Main.hs@@ -374,7 +386,7 @@ hs-source-dirs: picture/TrueType build-depends: , base >=4.8 && <5- , brillo >=2.0 && <3.0+ , brillo >=3.0 && <4.0 , directory >=1.3 && <1.4 , freetype2 >=0.2 && <0.4 , text >=2.0 && <2.2@@ -387,7 +399,7 @@ hs-source-dirs: picture/GUI build-depends: , base >=4.8 && <5- , brillo >=2.0 && <3.0+ , brillo >=3.0 && <4.0 , directory >=1.3 && <1.4 , text >=2.0 && <2.2 @@ -399,7 +411,7 @@ hs-source-dirs: picture/2048 build-depends: , base >=4.8 && <5- , brillo >=2.0 && <3.0+ , brillo >=3.0 && <4.0 , random >=1.2 && <1.3 , split >=0.2 && <0.3 , text >=2.0 && <2.2@@ -420,7 +432,7 @@ build-depends: , base >=4.8 && <5- , brillo >=2.0 && <3.0+ , brillo >=3.0 && <4.0 , containers >=0.5 && <0.9 , directory >=1.3 && <1.4 , mtl >=2.2 && <2.4@@ -435,7 +447,7 @@ hs-source-dirs: picture/Chess build-depends: , base >=4.8 && <5- , brillo >=2.0 && <3.0+ , brillo >=3.0 && <4.0 , containers >=0.5 && <0.9 , text >=2.0 && <2.2 @@ -452,7 +464,7 @@ build-depends: , base >=4.8 && <5- , brillo >=2.0 && <3.0+ , brillo >=3.0 && <4.0 , text >=2.0 && <2.2 ghc-options: -O2 -Wall -threaded -rtsopts@@ -463,12 +475,23 @@ hs-source-dirs: picture/Snake build-depends: , base >=4.8 && <5- , brillo >=2.0 && <3.0+ , brillo >=3.0 && <4.0 , random >=1.2 && <1.3 , text >=2.0 && <2.2 ghc-options: -O2 -Wall -threaded -rtsopts +executable brillo-spaceinvaders+ default-language: GHC2021+ main-is: Main.hs+ hs-source-dirs: picture/SpaceInvaders+ build-depends:+ , base >=4.8 && <5+ , brillo >=3.0 && <4.0+ , text >=2.0 && <2.2++ ghc-options: -O2 -Wall -threaded -rtsopts+ executable brillo-tictactoe default-language: GHC2021 main-is: Main.hs@@ -476,7 +499,7 @@ build-depends: , array >=0.5 && <0.6 , base >=4.8 && <5- , brillo >=2.0 && <3.0+ , brillo >=3.0 && <4.0 , random >=1.2 && <1.3 , text >=2.0 && <2.2 @@ -487,10 +510,10 @@ main-is: Main.hs hs-source-dirs: picture/Export build-depends:- , base >=4.8 && <5- , brillo >=2.0 && <3.0- , brillo-export >=0.2 && <0.3- , directory >=1.3 && <1.4+ , base >=4.8 && <5+ , brillo >=3.0 && <4.0+ , brillo-export >=0.2.1 && <0.3+ , directory >=1.3 && <1.4 ghc-options: -O2 -Wall -threaded -rtsopts @@ -499,10 +522,10 @@ main-is: Main.hs hs-source-dirs: picture/CanvasEditor build-depends:- , base >=4.8 && <5- , brillo >=2.0 && <3.0- , brillo-export >=0.2 && <0.3- , directory >=1.3 && <1.4+ , base >=4.8 && <5+ , brillo >=3.0 && <4.0+ , brillo-export >=0.2.1 && <0.3+ , directory >=1.3 && <1.4 ghc-options: -O2 -Wall -threaded -rtsopts @@ -512,19 +535,30 @@ hs-source-dirs: picture/FuleLayout build-depends: , base >=4.8 && <5- , brillo >=2.0 && <3.0+ , brillo >=3.0 && <4.0 , FULE >=0.3 && <0.4 , text >=2.0 && <2.2 ghc-options: -O2 -Wall -threaded -rtsopts +executable brillo-shader+ default-language: GHC2021+ main-is: Main.hs+ hs-source-dirs: picture/Shader+ build-depends:+ , base >=4.8 && <5+ , brillo >=3.0 && <4.0+ , text >=2.0 && <2.2++ ghc-options: -O2 -Wall -threaded -rtsopts+ executable brillo-cursors default-language: GHC2021 main-is: Main.hs hs-source-dirs: picture/Cursors build-depends: , base >=4.8 && <5- , brillo >=2.0 && <3.0+ , brillo >=3.0 && <4.0 , directory >=1.3 && <1.4 , text >=2.0 && <2.2
+ picture/CompressedBitmap/Main.hs view
@@ -0,0 +1,219 @@+{-| Demo of GPU-compressed (DXT1 / BC1) textures.++Loads an uncompressed BMP, encodes it to DXT1 in pure Haskell, and shows+both side by side. The left tile lives in VRAM as RGBA8 (4 B/pixel); the+right tile is uploaded via @glCompressedTexImage2D@ as DXT1 (0.5 B/pixel)+and decoded by the GPU at sample time.+-}+module Main where++import Brillo+import Data.Bits (shiftL, shiftR, (.&.), (.|.))+import Data.ByteString (ByteString)+import Data.ByteString qualified as BS+import Data.ByteString.Builder qualified as BSB+import Data.ByteString.Lazy qualified as BSL+import Data.List qualified as List+import Data.Text qualified as T+import Data.Word (Word16, Word32, Word8)+import Foreign.ForeignPtr (withForeignPtr)+import Foreign.Ptr (Ptr)+import Foreign.Storable (peekByteOff)+import System.Environment (getArgs)+import System.IO.Unsafe (unsafePerformIO)+++defaultBmpPath :: FilePath+defaultBmpPath = "brillo-examples/picture/Bitmap/lena-101x101.bmp"+++main :: IO ()+main = do+ args <- getArgs+ let path = case args of+ [p] -> p+ _ -> defaultBmpPath++ picture <- loadBMP path+ case picture of+ Bitmap bmpData -> run path bmpData+ _ -> error "loadBMP did not return a Bitmap"+++run :: FilePath -> BitmapData -> IO ()+run path bmpData = do+ let (srcW, srcH) = bitmapSize bmpData+ -- DXT1 blocks are 4×4 pixels, so crop to a multiple of 4.+ w = srcW - srcW `mod` 4+ h = srcH - srcH `mod` 4+ compressedBytes = encodeDXT1 bmpData w h+ compressedPic =+ compressedBitmapOfByteString+ w+ h+ TopToBottom+ compressedRGB_S3TC_DXT1+ compressedBytes+ True+ croppedUncompressed = BitmapSection (Rectangle (0, 0) (w, h)) bmpData++ gap = 20 :: Int+ windowW = w * 2 + gap * 3+ windowH = h + gap * 2+ offset = fromIntegral w / 2 + fromIntegral gap / 2 :: Float++ putStrLn $+ "Source: "+ <> path+ <> " ("+ <> show srcW+ <> "×"+ <> show srcH+ <> "), DXT1 payload: "+ <> show (BS.length compressedBytes)+ <> " B for "+ <> show w+ <> "×"+ <> show h+ <> " (uncompressed would be "+ <> show (w * h * 4)+ <> " B)"++ display+ ( InWindow+ (T.pack "Compressed Textures (RGBA8 vs DXT1)")+ (windowW, windowH)+ (40, 40)+ )+ (greyN 0.15)+ ( Pictures+ [ Translate (-offset) 0 croppedUncompressed+ , Translate offset 0 compressedPic+ ]+ )+++-- DXT1 (BC1) encoder ---------------------------------------------------------+-- 4×4 pixel blocks → 8 bytes each; ~6:1 compression vs RGBA8.++encodeDXT1 :: BitmapData -> Int -> Int -> ByteString+encodeDXT1 bmpData w h =+ unsafePerformIO $+ withForeignPtr (bitmapPointer bmpData) $ \ptr -> do+ let (srcW, srcH) = bitmapSize bmpData+ builder <-+ mconcat+ <$> sequence+ [ encodeBlock ptr srcW srcH bx by+ | by <- [0, 4 .. h - 1]+ , bx <- [0, 4 .. w - 1]+ ]+ pure $ BSL.toStrict (BSB.toLazyByteString builder)+++{-| Read one 4×4 block of RGB triples from the source BMP (which is stored+bottom-to-top) and emit its 8-byte DXT1 representation.+-}+encodeBlock :: Ptr Word8 -> Int -> Int -> Int -> Int -> IO BSB.Builder+encodeBlock ptr srcW srcH bx by = do+ pixels <-+ traverse readPixel [(bx + dx, by + dy) | dy <- [0 .. 3], dx <- [0 .. 3]]+ pure (blockBytes pixels)+ where+ readPixel (x, y) = do+ let sy = srcH - 1 - y -- BMP is bottom-to-top; flip to top-to-bottom.+ off = (sy * srcW + x) * 4+ r <- peekByteOff ptr off :: IO Word8+ g <- peekByteOff ptr (off + 1) :: IO Word8+ b <- peekByteOff ptr (off + 2) :: IO Word8+ pure (r, g, b)+++{-| Given 16 RGB pixels in row-major order, pick endpoints by luminance,+snap each pixel to its nearest palette entry, and emit 8 bytes.+-}+blockBytes :: [(Word8, Word8, Word8)] -> BSB.Builder+blockBytes pixels =+ let+ (cMin, cMax) = endpointsByLuminance pixels+ (c0Initial, c1Initial) = (toRGB565 cMax, toRGB565 cMin)+ -- Ensure 4-color mode by keeping c0 > c1 as uint16.+ (c0, c1) =+ if c0Initial >= c1Initial+ then (c0Initial, c1Initial)+ else (c1Initial, c0Initial)+ p0 = fromRGB565 c0+ p1 = fromRGB565 c1+ p2 = lerp23 p0 p1+ p3 = lerp23 p1 p0+ palette = [p0, p1, p2, p3]+ indices = zip [0 :: Int ..] (map (nearestIndex palette) pixels)+ packed =+ List.foldl'+ (\acc (i, idx) -> acc .|. (fromIntegral idx `shiftL` (2 * i)))+ (0 :: Word32)+ indices+ in+ BSB.word16LE c0 <> BSB.word16LE c1 <> BSB.word32LE packed+++-- | Single pass over the pixels picking the darkest and brightest by luminance.+endpointsByLuminance ::+ [(Word8, Word8, Word8)] ->+ ((Word8, Word8, Word8), (Word8, Word8, Word8))+endpointsByLuminance pixels =+ let decorated = [(luminance p, p) | p <- pixels]+ pick cmp = snd . foldr1 (\a b -> if cmp (fst a) (fst b) then a else b)+ in (pick (<) decorated, pick (>) decorated)+++toRGB565 :: (Word8, Word8, Word8) -> Word16+toRGB565 (r, g, b) =+ ((fromIntegral r `shiftR` 3) `shiftL` 11)+ .|. ((fromIntegral g `shiftR` 2) `shiftL` 5)+ .|. (fromIntegral b `shiftR` 3)+++fromRGB565 :: Word16 -> (Word8, Word8, Word8)+fromRGB565 c =+ let r5 = fromIntegral ((c `shiftR` 11) .&. 0x1F)+ g6 = fromIntegral ((c `shiftR` 5) .&. 0x3F)+ b5 = fromIntegral (c .&. 0x1F)+ in ( (r5 `shiftL` 3) .|. (r5 `shiftR` 2)+ , (g6 `shiftL` 2) .|. (g6 `shiftR` 4)+ , (b5 `shiftL` 3) .|. (b5 `shiftR` 2)+ )+++-- | Integer (2/3, 1/3) interpolation between two endpoint colors.+lerp23 ::+ (Word8, Word8, Word8) ->+ (Word8, Word8, Word8) ->+ (Word8, Word8, Word8)+lerp23 (r0, g0, b0) (r1, g1, b1) =+ (mix r0 r1, mix g0 g1, mix b0 b1)+ where+ mix a b =+ fromIntegral+ ((2 * fromIntegral a + fromIntegral b + 1 :: Int) `div` 3)+++-- | BT.601 luma weights × 100 (integer-only).+luminance :: (Word8, Word8, Word8) -> Int+luminance (r, g, b) =+ fromIntegral r * 30 + fromIntegral g * 59 + fromIntegral b * 11+++nearestIndex :: [(Word8, Word8, Word8)] -> (Word8, Word8, Word8) -> Int+nearestIndex palette c =+ fst $+ foldr1+ (\(i, d) (j, d') -> if d <= d' then (i, d) else (j, d'))+ (zip [0 ..] (map (squaredDist c) palette))+++squaredDist ::+ (Word8, Word8, Word8) -> (Word8, Word8, Word8) -> Int+squaredDist (r1, g1, b1) (r2, g2, b2) =+ let s a b = let x = fromIntegral a - fromIntegral b :: Int in x * x+ in s r1 r2 + s g1 g2 + s b1 b2
+ picture/Shader/Main.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Example of custom GLSL shaders rendered via the Brillo 'Shader' picture type.+module Main where++import Brillo+import Data.Text (Text)+++main :: IO ()+main =+ animate+ ( InWindow+ "Custom Shader" -- window title+ (600, 600) -- window size+ (10, 10) -- window position+ )+ black+ frame+++frame :: Float -> Picture+frame t =+ Pictures+ [ -- Rounded rectangle on the left+ Translate (-160) 0 $+ Color (makeColorI 255 200 0 255) $+ shader+ 200+ 200+ roundedRectFrag+ [ ("uSize", UniformVec2 200 200)+ , ("uRadius", UniformFloat 30)+ ]+ , -- Animated flame on the right+ Translate 160 (-20) $+ shader+ 200+ 300+ flameFrag+ [("uTime", UniformFloat t)]+ ]+++-- | Fragment shader that draws a rounded rectangle using a signed distance field.+roundedRectFrag :: Text+roundedRectFrag =+ "#version 120\n\+ \varying vec2 vLocalCoord;\n\+ \uniform vec2 uSize;\n\+ \uniform float uRadius;\n\+ \void main() {\n\+ \ vec2 halfSize = uSize * 0.5 - vec2(uRadius);\n\+ \ vec2 d = abs(vLocalCoord) - halfSize;\n\+ \ float dist = length(max(d, 0.0)) + min(max(d.x, d.y), 0.0) - uRadius;\n\+ \ float pixelSize = length(vec2(dFdx(dist), dFdy(dist)));\n\+ \ float alpha = 1.0 - smoothstep(-pixelSize, pixelSize, dist);\n\+ \ if (alpha < 0.001) discard;\n\+ \ gl_FragColor = vec4(gl_Color.rgb, gl_Color.a * alpha);\n\+ \}"+++{-| Fragment shader that draws a simple procedural flame.+Uses layered sine waves distorted over time to shape the flame,+colored from deep red at the tip through orange to bright yellow at the base.+-}+flameFrag :: Text+flameFrag =+ "#version 120\n\+ \varying vec2 vLocalCoord;\n\+ \uniform float uTime;\n\+ \void main() {\n\+ \ vec2 uv = vLocalCoord;\n\+ \ float h = 150.0;\n\+ \ float ny = (uv.y + h) / (2.0 * h);\n\+ \ float nx = uv.x / 100.0;\n\+ \ float envelope = (1.0 - ny) * (1.0 - ny);\n\+ \ float wave = 0.0;\n\+ \ wave += 0.3 * sin(nx * 6.0 + uTime * 3.0 + ny * 4.0);\n\+ \ wave += 0.2 * sin(nx * 10.0 - uTime * 5.0 + ny * 6.0);\n\+ \ wave += 0.1 * sin(nx * 16.0 + uTime * 7.0);\n\+ \ float shape = envelope - abs(nx + wave * 0.3 * ny);\n\+ \ shape = smoothstep(0.0, 0.5, shape);\n\+ \ if (shape < 0.001) discard;\n\+ \ float t = clamp(ny, 0.0, 1.0);\n\+ \ // Deep red at tip, orange in middle, bright yellow at base\n\+ \ vec3 tipColor = vec3(0.6, 0.0, 0.0);\n\+ \ vec3 midColor = vec3(0.9, 0.15, 0.0);\n\+ \ vec3 baseColor = vec3(1.0, 0.7, 0.1);\n\+ \ vec3 col = mix(baseColor, midColor, t);\n\+ \ col = mix(col, tipColor, t * t);\n\+ \ // Slight bright core at bottom center\n\+ \ float core = (1.0 - t) * (1.0 - abs(nx) * 2.0);\n\+ \ core = max(core, 0.0);\n\+ \ col = mix(col, vec3(1.0, 0.85, 0.4), core * core);\n\+ \ gl_FragColor = vec4(col, shape);\n\+ \}"
+ picture/SpaceInvaders/Main.hs view
@@ -0,0 +1,519 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}++module Main (main) where++import Brillo+import Brillo.Data.Point (pointInBox)+import Brillo.Interface.Pure.Game+import Data.Function ((&))+import Data.List (partition)+import Data.List qualified as List+import Data.Text qualified as T+++-- Constants++windowWidth, windowHeight :: Float+windowWidth = 640+windowHeight = 480+++playerY :: Float+playerY = -200+++playerSpeed :: Float+playerSpeed = 200+++bulletSpeed :: Float+bulletSpeed = 300+++alienBulletSpeed :: Float+alienBulletSpeed = 150+++alienStepX :: Float+alienStepX = 20+++alienStepY :: Float+alienStepY = 20+++alienMoveInterval :: Float+alienMoveInterval = 0.6+++alienShootInterval :: Float+alienShootInterval = 1.2+++cols :: Int+cols = 11+++rows :: Int+rows = 5+++totalAliens :: Int+totalAliens = cols * rows+++-- Types++data Alien = Octopus | Crab | Squid+++data Direction = DirLeft | DirRight+++flipDir :: Direction -> Direction+flipDir DirLeft = DirRight+flipDir DirRight = DirLeft+++dirSign :: Direction -> Float+dirSign DirLeft = -1+dirSign DirRight = 1+++data AlienInfo = AlienInfo+ { alienType :: Alien+ , alienPos :: (Float, Float)+ , alive :: Bool+ }+++data Bullet = Bullet+ { bulletPos :: (Float, Float)+ }+++data Shield = Shield+ { shieldPos :: (Float, Float)+ , shieldHealth :: Int+ }+++data Phase = WaitingToStart | Playing | Won | Dead+ deriving (Eq)+++data Keys = Keys+ { leftHeld :: Bool+ , rightHeld :: Bool+ }+++data GameState = GameState+ { playerX :: Float+ , playerBullet :: Maybe Bullet+ , alienBullets :: [Bullet]+ , aliens :: [AlienInfo]+ , aliveCount :: Int+ , shields :: [Shield]+ , alienDir :: Direction+ , alienTimer :: Float+ , alienShootTimer :: Float+ , score :: Int+ , lives :: Int+ , phase :: Phase+ , moveDown :: Bool+ , keysHeld :: Keys+ }+++-- Alien scoring++alienToPoints :: Alien -> Int+alienToPoints = \case+ Octopus -> 10+ Crab -> 20+ Squid -> 30+++-- Initial state++makeAlienGrid :: [AlienInfo]+makeAlienGrid =+ [ AlienInfo+ { alienType = alienForRow r+ , alienPos = (fromIntegral c * 40 - 200, fromIntegral r * 35 + 40)+ , alive = True+ }+ | r <- [0 .. rows - 1]+ , c <- [0 .. cols - 1]+ ]+ where+ alienForRow r+ | r < 2 = Octopus+ | r < 4 = Crab+ | otherwise = Squid+++makeShields :: [Shield]+makeShields =+ [ Shield (x, -140) 4+ | x <- [-180, -60, 60, 180]+ ]+++initialState :: GameState+initialState =+ GameState+ { playerX = 0+ , playerBullet = Nothing+ , alienBullets = []+ , aliens = makeAlienGrid+ , aliveCount = totalAliens+ , shields = makeShields+ , alienDir = DirRight+ , alienTimer = 0+ , alienShootTimer = 0+ , score = 0+ , lives = 3+ , phase = WaitingToStart+ , moveDown = False+ , keysHeld = Keys False False+ }+++-- Rendering++render :: GameState -> Picture+render gs =+ Pictures $+ concat+ [ [drawPlayer gs.playerX]+ , map drawAlienInfo (filter (.alive) gs.aliens)+ , maybe [] (\b -> [drawBullet green b]) gs.playerBullet+ , map (drawBullet white) gs.alienBullets+ , map drawShield gs.shields+ , [drawLabel (-300) "SCORE: " gs.score, drawLabel 200 "LIVES: " gs.lives]+ , overlay+ ]+ where+ drawPlayer :: Float -> Picture+ drawPlayer px =+ Color green $+ Translate px playerY $+ Pictures+ [ rectangleSolid 30 10+ , Translate 0 7 $ rectangleSolid 6 10+ ]++ drawAlienInfo :: AlienInfo -> Picture+ drawAlienInfo ai =+ let (ax, ay) = ai.alienPos+ in Color (alienColor ai.alienType) $+ Translate ax ay $+ drawAlien ai.alienType++ drawAlien :: Alien -> Picture+ drawAlien Octopus =+ Pictures+ [ rectangleSolid 16 12+ , Translate (-8) (-6) $ rectangleSolid 4 6+ , Translate 8 (-6) $ rectangleSolid 4 6+ ]+ drawAlien Crab =+ Pictures+ [ rectangleSolid 20 10+ , Translate (-10) 2 $ rectangleSolid 4 8+ , Translate 10 2 $ rectangleSolid 4 8+ ]+ drawAlien Squid =+ Pictures+ [ rectangleSolid 14 14+ , Translate 0 10 $ rectangleSolid 6 6+ ]++ alienColor :: Alien -> Color+ alienColor Octopus = cyan+ alienColor Crab = white+ alienColor Squid = magenta++ drawBullet :: Color -> Bullet -> Picture+ drawBullet clr b =+ let (bx, by) = b.bulletPos+ in Color clr $ Translate bx by $ rectangleSolid 2 8++ drawShield :: Shield -> Picture+ drawShield s =+ let (sx, sy) = s.shieldPos+ intensity = fromIntegral s.shieldHealth / 4.0+ in Color (makeColor 0 intensity 0 1) $+ Translate sx sy $+ rectangleSolid 40 20++ drawLabel :: Float -> String -> Int -> Picture+ drawLabel tx label n =+ Color white $+ Translate tx 220 $+ Scale 0.15 0.15 $+ Text $+ T.pack (label ++ show n)++ overlay = case gs.phase of+ WaitingToStart ->+ [ Color white $+ Translate (-155) 0 $+ Scale 0.2 0.2 $+ Text "Press SPACE to start."+ ]+ Dead ->+ [ Color red $+ Translate (-200) 0 $+ Scale 0.5 0.5 $+ Text "GAME OVER"+ , Color white $+ Translate (-175) (-50) $+ Scale 0.2 0.2 $+ Text "Press SPACE to try again."+ ]+ Won ->+ [ Color green $+ Translate (-160) 0 $+ Scale 0.5 0.5 $+ Text "YOU WIN!"+ , Color white $+ Translate (-175) (-50) $+ Scale 0.2 0.2 $+ Text "Press SPACE to play again."+ ]+ Playing -> []+++-- Input handling++handleInput :: Event -> GameState -> GameState+handleInput (EventKey (SpecialKey KeySpace) Down _ _) gs = case gs.phase of+ WaitingToStart -> gs{phase = Playing}+ Dead -> initialState{phase = Playing}+ Won -> initialState{phase = Playing}+ Playing -> shoot gs+handleInput (EventKey (SpecialKey KeyLeft) ks _ _) gs =+ gs{keysHeld = (gs.keysHeld){leftHeld = ks == Down}}+handleInput (EventKey (SpecialKey KeyRight) ks _ _) gs =+ gs{keysHeld = (gs.keysHeld){rightHeld = ks == Down}}+handleInput _ gs = gs+++shoot :: GameState -> GameState+shoot gs = case gs.playerBullet of+ -- Classic Space Invaders only allows one player bullet on screen+ Just _ -> gs+ Nothing ->+ gs{playerBullet = Just Bullet{bulletPos = (gs.playerX, playerY + 15)}}+++-- Update++update :: Float -> GameState -> GameState+update dt gs+ | gs.phase /= Playing = gs+ | otherwise =+ gs+ & movePlayer dt+ & movePlayerBullet dt+ & moveAlienBullets dt+ & stepAliens dt+ & alienShooting dt+ & checkCollisions+ & checkWinLose+++movePlayer :: Float -> GameState -> GameState+movePlayer dt gs =+ let Keys l r = gs.keysHeld+ dx+ | l && not r = -playerSpeed * dt+ | r && not l = playerSpeed * dt+ | otherwise = 0+ in gs{playerX = clamp (-280) 280 (gs.playerX + dx)}+++clamp :: Float -> Float -> Float -> Float+clamp lo hi x = max lo (min hi x)+++movePlayerBullet :: Float -> GameState -> GameState+movePlayerBullet dt gs = case gs.playerBullet of+ Nothing -> gs+ Just b ->+ let (bx, by) = b.bulletPos+ newY = by + bulletSpeed * dt+ in if newY > windowHeight / 2+ then gs{playerBullet = Nothing}+ else gs{playerBullet = Just b{bulletPos = (bx, newY)}}+++moveAlienBullets :: Float -> GameState -> GameState+moveAlienBullets dt gs =+ let lowerBound = -(windowHeight / 2)+ step b =+ let (bx, by) = b.bulletPos+ in b{bulletPos = (bx, by - alienBulletSpeed * dt)}+ keep b = snd b.bulletPos > lowerBound+ in gs{alienBullets = filter keep (map step gs.alienBullets)}+++stepAliens :: Float -> GameState -> GameState+stepAliens dt gs+ | newTimer < currentInterval gs = gs{alienTimer = newTimer}+ | gs.moveDown = moveAliensDown gs'+ | otherwise = moveAliensSideways gs'+ where+ newTimer = gs.alienTimer + dt+ gs' = gs{alienTimer = 0}+++-- Speed up as aliens are destroyed+currentInterval :: GameState -> Float+currentInterval gs =+ let ratio = fromIntegral gs.aliveCount / fromIntegral totalAliens+ in max 0.05 (alienMoveInterval * ratio)+++mapAlive :: ((Float, Float) -> (Float, Float)) -> [AlienInfo] -> [AlienInfo]+mapAlive f = map (\a -> if a.alive then a{alienPos = f a.alienPos} else a)+++moveAliensSideways :: GameState -> GameState+moveAliensSideways gs =+ let dx = alienStepX * dirSign gs.alienDir+ moved = mapAlive (\(x, y) -> (x + dx, y)) gs.aliens+ extent (lo, hi) a+ | not a.alive = (lo, hi)+ | otherwise = let x = fst a.alienPos in (min lo x, max hi x)+ (minX, maxX) = List.foldl' extent (1 / 0, -(1 / 0)) moved+ hitEdge = maxX > 280 || minX < -280+ in gs{aliens = moved, moveDown = hitEdge}+++moveAliensDown :: GameState -> GameState+moveAliensDown gs =+ gs+ { aliens = mapAlive (\(x, y) -> (x, y - alienStepY)) gs.aliens+ , alienDir = flipDir gs.alienDir+ , moveDown = False+ }+++alienShooting :: Float -> GameState -> GameState+alienShooting dt gs+ | newTimer < alienShootInterval = gs{alienShootTimer = newTimer}+ | null aliveAliens = gs{alienShootTimer = 0}+ | otherwise =+ let shooterIdx = floor (newTimer * 1000) `mod` length aliveAliens+ shooter = aliveAliens !! shooterIdx+ (sx, sy) = shooter.alienPos+ newBullet = Bullet{bulletPos = (sx, sy - 15)}+ in gs+ { alienBullets = newBullet : gs.alienBullets+ , alienShootTimer = 0+ }+ where+ newTimer = gs.alienShootTimer + dt+ aliveAliens = filter (.alive) gs.aliens+++checkCollisions :: GameState -> GameState+checkCollisions gs =+ gs+ & playerBulletHitsAliens+ & alienBulletsHitPlayer+ & bulletsHitShields+++playerBulletHitsAliens :: GameState -> GameState+playerBulletHitsAliens gs = case gs.playerBullet of+ Nothing -> gs+ Just b ->+ let (hit, newAliens, points) = checkAlienHits b gs.aliens+ in if hit+ then+ gs+ { playerBullet = Nothing+ , aliens = newAliens+ , aliveCount = gs.aliveCount - 1+ , score = gs.score + points+ }+ else gs+++checkAlienHits :: Bullet -> [AlienInfo] -> (Bool, [AlienInfo], Int)+checkAlienHits _ [] = (False, [], 0)+checkAlienHits b (a : as)+ | a.alive && bulletHits 12 10 b a.alienPos =+ (True, a{alive = False} : as, alienToPoints a.alienType)+ | otherwise =+ let (hit, rest, pts) = checkAlienHits b as+ in (hit, a : rest, pts)+++bulletHits :: Float -> Float -> Bullet -> (Float, Float) -> Bool+bulletHits hw hh b (cx, cy) =+ pointInBox b.bulletPos (cx - hw, cy - hh) (cx + hw, cy + hh)+++alienBulletsHitPlayer :: GameState -> GameState+alienBulletsHitPlayer gs =+ let playerPos = (gs.playerX, playerY)+ (hitBullets, safeBullets) =+ partition (\b -> bulletHits 15 10 b playerPos) gs.alienBullets+ in if null hitBullets+ then gs+ else gs{alienBullets = safeBullets, lives = gs.lives - 1}+++bulletsHitShields :: GameState -> GameState+bulletsHitShields gs =+ let (pb', shields1) = case gs.playerBullet of+ Nothing -> (Nothing, gs.shields)+ Just b -> checkBulletShields b gs.shields+ (alienBullets', shields2) =+ foldr checkAlienBullet ([], shields1) gs.alienBullets+ in gs{playerBullet = pb', alienBullets = alienBullets', shields = shields2}+ where+ checkBulletShields :: Bullet -> [Shield] -> (Maybe Bullet, [Shield])+ checkBulletShields b [] = (Just b, [])+ checkBulletShields b (s : ss)+ | s.shieldHealth > 0 && bulletHits 22 12 b s.shieldPos =+ (Nothing, s{shieldHealth = s.shieldHealth - 1} : ss)+ | otherwise =+ let (b', ss') = checkBulletShields b ss+ in (b', s : ss')++ checkAlienBullet :: Bullet -> ([Bullet], [Shield]) -> ([Bullet], [Shield])+ checkAlienBullet b (bs, ss) =+ case checkBulletShields b ss of+ (Just b', ss') -> (b' : bs, ss')+ (Nothing, ss') -> (bs, ss')+++checkWinLose :: GameState -> GameState+checkWinLose gs+ | gs.lives <= 0 = gs{phase = Dead}+ | gs.aliveCount == 0 = gs{phase = Won}+ | any alienTooLow gs.aliens = gs{phase = Dead}+ | otherwise = gs+ where+ alienTooLow a = a.alive && snd a.alienPos < playerY + 30+++main :: IO ()+main =+ play+ (InWindow "Space Invaders" (round windowWidth, round windowHeight) (100, 100))+ black+ 60+ initialState+ render+ handleInput+ update