diff --git a/brillo-examples.cabal b/brillo-examples.cabal --- a/brillo-examples.cabal +++ b/brillo-examples.cabal @@ -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 diff --git a/picture/CompressedBitmap/Main.hs b/picture/CompressedBitmap/Main.hs new file mode 100644 --- /dev/null +++ b/picture/CompressedBitmap/Main.hs @@ -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 diff --git a/picture/Shader/Main.hs b/picture/Shader/Main.hs new file mode 100644 --- /dev/null +++ b/picture/Shader/Main.hs @@ -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\ + \}" diff --git a/picture/SpaceInvaders/Main.hs b/picture/SpaceInvaders/Main.hs new file mode 100644 --- /dev/null +++ b/picture/SpaceInvaders/Main.hs @@ -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