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: 1.13.3 +version: 2.0.0 license: MIT license-file: LICENSE author: Ben Lippmeier, Adrian Sieber @@ -14,6 +14,7 @@ A mixed bag of fractals, particle simulations and cellular automata. synopsis: Examples using the Brillo library +tested-with: GHC ==9.4.8 || ==9.6.7 || ==9.8.4 || ==9.10.3 || ==9.12.2 flag llvm description: @@ -26,15 +27,35 @@ type: git location: https://github.com/ad-si/Brillo +executable brillo-antialiasing + default-language: GHC2021 + main-is: Main.hs + hs-source-dirs: picture/Antialiasing + build-depends: + , base >=4.8 && <5 + , brillo >=2.0 && <3.0 + + ghc-options: -O2 -Wall -threaded -rtsopts + +executable brillo-circle-comparison + default-language: GHC2021 + main-is: Main.hs + hs-source-dirs: picture/CircleComparison + build-depends: + , base >=4.8 && <5 + , brillo >=2.0 && <3.0 + , text >=2.0 && <2.2 + + ghc-options: -O2 -Wall -threaded -rtsopts + executable brillo-bitmap default-language: GHC2021 main-is: Main.hs hs-source-dirs: picture/Bitmap build-depends: - , base >=4.8 && <5 - , bmp >=1.2 && <1.3 - , brillo >=1.13.3 && <1.15 - , bytestring >=0.11 && <0.12 + , base >=4.8 && <5 + , brillo >=2.0 && <3.0 + , text >=2.0 && <2.2 ghc-options: -O2 -Wall -threaded -rtsopts @@ -47,9 +68,9 @@ Vec2 build-depends: - , base >=4.8 && <5 - , brillo >=1.13.3 && <1.15 - , random >=1.2 && <1.3 + , base >=4.8 && <5 + , brillo >=2.0 && <3.0 + , random >=1.2 && <1.3 ghc-options: -O2 -threaded -rtsopts @@ -58,8 +79,9 @@ main-is: Main.hs hs-source-dirs: picture/Clock build-depends: - , base >=4.8 && <5 - , brillo >=1.13.3 && <1.15 + , base >=4.8 && <5 + , brillo >=2.0 && <3.0 + , text >=2.0 && <2.2 ghc-options: -O2 -Wall -threaded -rtsopts @@ -68,9 +90,8 @@ main-is: Main.hs hs-source-dirs: picture/Color build-depends: - , base >=4.8 && <5 - , brillo >=1.13.3 && <1.15 - , vector >=0.13 && <0.14 + , base >=4.8 && <5 + , brillo >=2.0 && <3.0 ghc-options: -O2 -Wall -threaded -rtsopts @@ -83,10 +104,10 @@ World build-depends: - , base >=4.8 && <5 - , brillo >=1.13.3 && <1.15 - , random >=1.2 && <1.3 - , vector >=0.13 && <0.14 + , base >=4.8 && <5 + , brillo >=2.0 && <3.0 + , random >=1.2 && <1.3 + , vector >=0.13 && <0.14 ghc-options: -O2 -Wall -threaded -rtsopts @@ -95,18 +116,29 @@ main-is: Main.hs hs-source-dirs: picture/Draw build-depends: - , base >=4.8 && <5 - , brillo >=1.13.3 && <1.15 + , base >=4.8 && <5 + , brillo >=2.0 && <3.0 ghc-options: -O2 -Wall -threaded -rtsopts +executable brillo-dropfiles + default-language: GHC2021 + main-is: Main.hs + hs-source-dirs: picture/DropFiles + build-depends: + , base >=4.8 && <5 + , brillo >=2.0 && <3.0 + , text >=2.0 && <2.2 + + ghc-options: -O2 -Wall -threaded -rtsopts + executable brillo-easy default-language: GHC2021 main-is: Main.hs hs-source-dirs: picture/Easy build-depends: - , base >=4.8 && <5 - , brillo >=1.13.3 && <1.15 + , base >=4.8 && <5 + , brillo >=2.0 && <3.0 ghc-options: -O2 -Wall -threaded -rtsopts @@ -120,9 +152,9 @@ World build-depends: - , base >=4.8 && <5 - , brillo >=1.13.3 && <1.15 - , random >=1.2 && <1.3 + , base >=4.8 && <5 + , brillo >=2.0 && <3.0 + , random >=1.2 && <1.3 ghc-options: -O2 -Wall -threaded -rtsopts @@ -131,8 +163,8 @@ main-is: Main.hs hs-source-dirs: picture/Flake build-depends: - , base >=4.8 && <5 - , brillo >=1.13.3 && <1.15 + , base >=4.8 && <5 + , brillo >=2.0 && <3.0 ghc-options: -O2 -Wall -threaded -rtsopts @@ -141,18 +173,30 @@ main-is: Main.hs hs-source-dirs: picture/GameEvent build-depends: - , base >=4.8 && <5 - , brillo >=1.13.3 && <1.15 + , base >=4.8 && <5 + , brillo >=2.0 && <3.0 + , text >=2.0 && <2.2 ghc-options: -O2 -Wall -threaded -rtsopts +executable brillo-interaction + default-language: GHC2021 + main-is: Main.hs + hs-source-dirs: picture/Interaction + build-depends: + , base >=4.8 && <5 + , brillo >=2.0 && <3.0 + , text >=2.0 && <2.2 + + ghc-options: -O2 -Wall -threaded -rtsopts + executable brillo-hello default-language: GHC2021 main-is: Main.hs hs-source-dirs: picture/Hello build-depends: - , base >=4.8 && <5 - , brillo >=1.13.3 && <1.15 + , base >=4.8 && <5 + , brillo >=2.0 && <3.0 ghc-options: -O2 -Wall -threaded -rtsopts @@ -166,19 +210,29 @@ World build-depends: - , base >=4.8 && <5 - , brillo >=1.13.3 && <1.15 - , random >=1.2 && <1.3 + , base >=4.8 && <5 + , brillo >=2.0 && <3.0 + , random >=1.2 && <1.3 ghc-options: -O2 -Wall -threaded -rtsopts +executable brillo-lines + default-language: GHC2021 + main-is: Main.hs + hs-source-dirs: picture/Lines + build-depends: + , base >=4.8 && <5 + , brillo >=2.0 && <3.0 + + ghc-options: -O2 -Wall -threaded -rtsopts + executable brillo-machina default-language: GHC2021 main-is: Main.hs hs-source-dirs: picture/Machina build-depends: - , base >=4.8 && <5 - , brillo >=1.13.3 && <1.15 + , base >=4.8 && <5 + , brillo >=2.0 && <3.0 ghc-options: -O2 -Wall -threaded -rtsopts @@ -193,12 +247,33 @@ World build-depends: - , base >=4.8 && <5 - , brillo >=1.13.3 && <1.15 - , brillo-algorithms >=1.13.3 && <1.15 + , base >=4.8 && <5 + , brillo >=2.0 && <3.0 + , brillo-algorithms >=2.0 && <3.0 ghc-options: -O2 -threaded -rtsopts +executable brillo-pickfiles + default-language: GHC2021 + main-is: Main.hs + hs-source-dirs: picture/PickFiles + build-depends: + , base >=4.8 && <5 + , brillo >=2.0 && <3.0 + , text >=2.0 && <2.2 + + ghc-options: -O2 -Wall -threaded -rtsopts + +executable brillo-polygons + default-language: GHC2021 + main-is: Main.hs + hs-source-dirs: picture/Polygons + build-depends: + , base >=4.8 && <5 + , brillo >=2.0 && <3.0 + + ghc-options: -O2 -Wall -threaded -rtsopts + executable brillo-styrene default-language: GHC2021 main-is: Main.hs @@ -213,10 +288,9 @@ World build-depends: - , base >=4.8 && <5 - , brillo >=1.13.3 && <1.15 - , containers >=0.5 && <0.7 - , ghc-prim + , base >=4.8 && <5 + , brillo >=2.0 && <3.0 + , containers >=0.5 && <0.9 ghc-options: -O2 -Wall -threaded -rtsopts @@ -225,8 +299,8 @@ main-is: Main.hs hs-source-dirs: picture/Tree build-depends: - , base >=4.8 && <5 - , brillo >=1.13.3 && <1.15 + , base >=4.8 && <5 + , brillo >=2.0 && <3.0 ghc-options: -O2 -Wall -threaded -rtsopts @@ -243,9 +317,9 @@ World build-depends: - , base >=4.8 && <5 - , brillo >=1.13.3 && <1.15 - , vector >=0.13 && <0.14 + , base >=4.8 && <5 + , brillo >=2.0 && <3.0 + , vector >=0.13 && <0.14 ghc-options: -O2 -Wall -threaded -rtsopts @@ -254,8 +328,8 @@ main-is: Main.hs hs-source-dirs: picture/Zen build-depends: - , base >=4.8 && <5 - , brillo >=1.13.3 && <1.15 + , base >=4.8 && <5 + , brillo >=2.0 && <3.0 ghc-options: -O2 -Wall -threaded -rtsopts @@ -264,10 +338,10 @@ main-is: Main.hs hs-source-dirs: picture/Graph build-depends: - , base >=4.8 && <5 - , brillo >=1.13.3 && <1.15 - , containers >=0.5 && <0.7 - , random >=1.2 && <1.3 + , base >=4.8 && <5 + , brillo >=2.0 && <3.0 + , containers >=0.5 && <0.9 + , random >=1.2 && <1.3 ghc-options: -O2 -Wall -threaded -rtsopts @@ -276,22 +350,182 @@ main-is: Main.hs hs-source-dirs: picture/Gravity build-depends: - , base >=4.8 && <5 - , brillo >=1.13.3 && <1.15 - , containers >=0.5 && <0.7 - , random >=1.2 && <1.3 + , base >=4.8 && <5 + , brillo >=2.0 && <3.0 + , random >=1.2 && <1.3 ghc-options: -O2 -Wall -threaded -rtsopts executable brillo-render default-language: GHC2021 build-depends: - , base >=4.8 && <5 - , brillo >=1.13.3 && <1.15 - , brillo-rendering >=1.13.3 && <1.15 - , containers >=0.5 && <0.7 - , GLFW-b >=3.3 && <4 + , base >=4.8 && <5 + , brillo >=2.0 && <3.0 + , brillo-rendering >=2.0 && <3.0 + , GLFW-b >=3.3 && <4 main-is: Main.hs hs-source-dirs: picture/Render + ghc-options: -O2 -Wall -threaded -rtsopts + +executable brillo-truetype + default-language: GHC2021 + main-is: Main.hs + hs-source-dirs: picture/TrueType + build-depends: + , base >=4.8 && <5 + , brillo >=2.0 && <3.0 + , directory >=1.3 && <1.4 + , freetype2 >=0.2 && <0.4 + , text >=2.0 && <2.2 + + ghc-options: -O2 -Wall -threaded -rtsopts + +executable brillo-gui + default-language: GHC2021 + main-is: Main.hs + hs-source-dirs: picture/GUI + build-depends: + , base >=4.8 && <5 + , brillo >=2.0 && <3.0 + , directory >=1.3 && <1.4 + , text >=2.0 && <2.2 + + ghc-options: -O2 -Wall -threaded -rtsopts + +executable brillo-2048 + default-language: GHC2021 + main-is: Main.hs + hs-source-dirs: picture/2048 + build-depends: + , base >=4.8 && <5 + , brillo >=2.0 && <3.0 + , random >=1.2 && <1.3 + , split >=0.2 && <0.3 + , text >=2.0 && <2.2 + + ghc-options: -O2 -Wall -threaded -rtsopts + +executable brillo-tetris + default-language: GHC2021 + main-is: Main.hs + hs-source-dirs: picture/Tetris picture/Tetris/src + other-modules: + Config + Drawing + Figures + Game + Util + World + + build-depends: + , base >=4.8 && <5 + , brillo >=2.0 && <3.0 + , containers >=0.5 && <0.9 + , directory >=1.3 && <1.4 + , mtl >=2.2 && <2.4 + , random >=1.2 && <1.3 + , text >=2.0 && <2.2 + + ghc-options: -O2 -Wall -threaded -rtsopts + +executable brillo-chess + default-language: GHC2021 + main-is: Main.hs + hs-source-dirs: picture/Chess + build-depends: + , base >=4.8 && <5 + , brillo >=2.0 && <3.0 + , containers >=0.5 && <0.9 + , text >=2.0 && <2.2 + + ghc-options: -O2 -Wall -threaded -rtsopts + +executable brillo-pacman + default-language: GHC2021 + main-is: Main.hs + hs-source-dirs: picture/PacMan + other-modules: + GhostAI + Maze + Structs + + build-depends: + , base >=4.8 && <5 + , brillo >=2.0 && <3.0 + , text >=2.0 && <2.2 + + ghc-options: -O2 -Wall -threaded -rtsopts + +executable brillo-snake + default-language: GHC2021 + main-is: Main.hs + hs-source-dirs: picture/Snake + build-depends: + , base >=4.8 && <5 + , brillo >=2.0 && <3.0 + , random >=1.2 && <1.3 + , text >=2.0 && <2.2 + + ghc-options: -O2 -Wall -threaded -rtsopts + +executable brillo-tictactoe + default-language: GHC2021 + main-is: Main.hs + hs-source-dirs: picture/TicTacToe + build-depends: + , array >=0.5 && <0.6 + , base >=4.8 && <5 + , brillo >=2.0 && <3.0 + , random >=1.2 && <1.3 + , text >=2.0 && <2.2 + + ghc-options: -O2 -Wall -threaded -rtsopts + +executable brillo-export + default-language: GHC2021 + main-is: Main.hs + hs-source-dirs: picture/Export + build-depends: + , base >=4.8 && <5 + , brillo >=2.0 && <3.0 + , brillo-export >=0.1 && <0.2 + , directory >=1.3 && <1.4 + + ghc-options: -O2 -Wall -threaded -rtsopts + +executable brillo-canvas-editor + default-language: GHC2021 + main-is: Main.hs + hs-source-dirs: picture/CanvasEditor + build-depends: + , base >=4.8 && <5 + , brillo >=2.0 && <3.0 + , brillo-export >=0.1 && <0.2 + , directory >=1.3 && <1.4 + + ghc-options: -O2 -Wall -threaded -rtsopts + +executable brillo-fule-layout + default-language: GHC2021 + main-is: Main.hs + hs-source-dirs: picture/FuleLayout + build-depends: + , base >=4.8 && <5 + , brillo >=2.0 && <3.0 + , FULE >=0.3 && <0.4 + , 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 + , directory >=1.3 && <1.4 + , text >=2.0 && <2.2 + ghc-options: -O2 -Wall -threaded -rtsopts diff --git a/picture/2048/Main.hs b/picture/2048/Main.hs new file mode 100644 --- /dev/null +++ b/picture/2048/Main.hs @@ -0,0 +1,417 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main (main) +where + +import Brillo +import Brillo.Interface.Pure.Game +import Data.List (transpose) +import Data.List.Split (chunksOf) +import Data.Text qualified as T +import System.Random (StdGen, getStdGen, random) + + +-------------------------------------------- +-- TODO: +-- loss detection +-- movement animations +-- aesthetic improvements +------------------------------------------- + +main :: IO () +main = do + g <- getStdGen + play + (InWindow "2048" (410, 500) (20, 20)) + (makeColorI 193 177 156 255) -- background color + fps -- simulation steps per second + (initPositions g) -- initial world + drawWorld -- function to convert world to picture + handleInputEvents -- TODO add randomness + stepWorld + + +fps :: Int +fps = 20 + + +data Tile = Tile {val :: Int, popInTime :: Float, popOutTime :: Float} + deriving (Eq, Show) +type Row = [Tile] +data World = World {board :: [[Tile]], gen :: StdGen, score :: Int} + + +instance Eq World where + x == y = board x == board y && score x == score y + + +--------------------------------------------- +-- Initial world generation +--------------------------------------------- + +toInt :: Bool -> Int +toInt True = 1 +toInt False = 0 + + +makeTile :: Int -> Tile +makeTile i = Tile{val = i, popInTime = 0.0, popOutTime = 0.0} + + +-- generates an initial world state with, on average, two 2s to start +initPositions :: StdGen -> World +initPositions g = + let origBoard = chunksOf 4 $ map makeTile $ replicate 16 0 + in addTile $ addTile World{board = origBoard, gen = g, score = 0} + + +-------------------------------------------- +-- Regeneration of 2s +-------------------------------------------- + +replaceNthZero :: Int -> Int -> [Tile] -> [Tile] +replaceNthZero _ _ [] = [] +replaceNthZero v 0 (x : xs) = + if val x == 0 + then (Tile{val = v, popInTime = 0.5, popOutTime = 0.0} : xs) + else x : (replaceNthZero v 0 xs) +replaceNthZero v n (x : xs) = + if val x == 0 + then x : (replaceNthZero v (n - 1) xs) + else x : (replaceNthZero v n xs) + + +reciprocalOddsOf4 :: Int +reciprocalOddsOf4 = 10 + + +addTile :: World -> World +addTile world = + let numZeros = (sum . (map toInt) . (map (== 0)) . map val . concat) (board world) + (rand, newGen) = random (gen world) :: (Int, StdGen) + n = if numZeros == 0 then 0 else rand `mod` numZeros + (rand2, _) = random newGen :: (Int, StdGen) + v = if rand2 `mod` reciprocalOddsOf4 == 0 then 4 else 2 + newBoard = chunksOf 4 $ replaceNthZero v n $ concat (board world) + in world{board = newBoard, gen = newGen} + + +--------------------------------------------- +-- Input handling +-- ----------------------------------------- +-- +data Direction = U | D | L | R + + +keyDir :: Key -> Maybe Direction +keyDir (SpecialKey KeyUp) = Just U +keyDir (SpecialKey KeyDown) = Just D +keyDir (SpecialKey KeyLeft) = Just L +keyDir (SpecialKey KeyRight) = Just R +keyDir _ = Nothing + + +handleInputEvents :: Event -> World -> World +handleInputEvents (EventKey k Down _ _) world = + let dir = keyDir k + newWorld = go dir world + in if newWorld == world + then world + else addTile newWorld +handleInputEvents _ x = x + + +-------------------------------------------------------- +-- Time steps: All they do is update the animations -- +-- ----------------------------------------------------- + +popInSpeed :: Float +popInSpeed = 4 + + +-- changes animation times for each tile +updateTile :: Float -> Tile -> Tile +updateTile dt t = + if val t > 0 + then + t + { popInTime = + if popInTime t - dt * popInSpeed > 0 then popInTime t - dt * popInSpeed else 0 + , popOutTime = + if popOutTime t - dt * popInSpeed > 0 then popOutTime t - dt * popInSpeed else 0 + } + else t{popInTime = 0, popOutTime = 0} + + +updateTiles :: Float -> [[Tile]] -> [[Tile]] +updateTiles dt tss = (map (map (updateTile dt))) tss + + +stepWorld :: Float -> World -> World +stepWorld dt world = world{board = updateTiles dt (board world)} + + +--------------------------------------------------------- +-- Drawing and display +--------------------------------------------------------- + +rowHgt :: Float +rowHgt = 100 + + +gameOverMessage :: Picture +gameOverMessage = + Pictures + [ Translate (-500) (-500) $ Color translucentWhite $ rectangleSolid 2000 2000 + , Translate (-335) (-150) $ + Scale 0.5 0.5 $ + Color black $ + Text (T.pack "Game Over") + ] + where + translucentWhite = makeColorI 255 255 255 150 + + +drawWorld :: World -> Picture +drawWorld w = case board w of + [r1, r2, r3, r4] -> + Translate (150) (150) $ + Pictures $ + [ drawRow r1 + , Translate 0 (-rowHgt) (drawRow r2) + , Translate 0 (-rowHgt * 2) (drawRow r3) + , Translate 0 (-rowHgt * 3) (drawRow r4) + , Translate (-300) 60 $ + Scale 0.2 0.2 $ + Color white $ + Text $ + T.pack $ + "Score: " ++ (show $ score w) + ] + ++ gameOverPicture + where + gameOverPicture = if lost then [gameOverMessage] else [] + lost = + go (Just R) w == w + && go (Just L) w == w + && go (Just U) w == w + && go (Just D) w == w + _ -> Blank + + +-- debugPicture ]) + +tileS :: Float +tileS = 90 + + +textScale :: Float +textScale = 0.2 + + +-- TODO: also make a zipper to *pictures* to also adjust number position, text color, etc. by number + +colorZipper :: [(Int, Color)] +colorZipper = + [ (2, makeColorI 238 228 218 255) + , (4, makeColorI 237 224 200 255) + , (8, makeColorI 242 177 121 255) + , (16, makeColorI 245 149 99 255) + , (32, makeColorI 246 124 95 255) + , (64, makeColorI 246 102 62 255) + , (128, makeColorI 238 208 114 255) + , (256, makeColorI 237 204 97 255) + , (512, makeColorI 237 200 80 255) + , (1024, makeColorI 237 197 63 255) + , (2048, makeColorI 237 194 46 255) + ] + + +getColor :: Int -> Color +getColor x = maybe white id (lookup x colorZipper) + + +quarterRoundedRect :: Int -> Float -> Float -> Float -> Path +quarterRoundedRect n w h r = + [(0, 0), (0, h / 2)] + ++ (reverse $ arcPath n (w / 2 - r, h / 2 - r) r) + ++ [(w / 2, 0)] + + +drawQuarterRoundedRect :: Int -> Float -> Float -> Float -> Picture +drawQuarterRoundedRect n w h r = Polygon $ quarterRoundedRect n w h r + + +-- takes width and height and radius and makes a filled rounded rectangle +-- the int is the precision / number of points +roundedRect :: Int -> Float -> Float -> Float -> Picture +roundedRect n w h r = + Pictures + [ drawQuarterRoundedRect n w h r + , Rotate 90 $ drawQuarterRoundedRect n w h r + , Rotate 180 $ drawQuarterRoundedRect n w h r + , Rotate 270 $ drawQuarterRoundedRect n w h r + ] + + +-- takes x, y, r, and theta and returns (x+r*cos theta, y+r*sin theta) +getPoint :: Float -> Float -> Float -> Float -> (Float, Float) +getPoint x y r th = (x + r * cos th, y + r * sin th) + + +-- takes center and radius and returns 90-degree arc path with n points +arcPath :: Int -> (Float, Float) -> Float -> Path +arcPath n (x, y) r = + map (getPoint x y r) $ + [0.0] ++ (map (\i -> pi / 2 / (fromIntegral i)) $ reverse [1 .. n + 1]) + + +tileRoundness :: Float +tileRoundness = 4 + + +tilePrecision :: Int +tilePrecision = 10 + + +-- Takes x-offset and draws the tile background +-- maybe unroll this into drawTile? +tileBackColor :: Color +tileBackColor = makeColorI 205 192 180 255 +drawTileBack :: Float -> Picture +drawTileBack x = + Color + tileBackColor + (Translate x 0 (roundedRect tilePrecision tileS tileS tileRoundness)) + + +-- Takes x-offset and tile and draws the tile itself +drawTile :: Float -> Tile -> Picture +drawTile x tile = + let background = + [ Color (getColor $ val tile) $ + roundedRect tilePrecision tileS tileS tileRoundness + ] + numStr = show (val tile) + numDigits = fromIntegral (length numStr) + charW = 104.76 * textScale + charH = 119.05 * textScale + number = + if val tile > 0 + then + [ Translate (-(numDigits * charW) / 2) (-charH / 2) $ + Scale textScale textScale $ + Text $ + T.pack numStr + ] + else [] + curScale = + if (popInTime tile) > 0 + then (1 - (popInTime tile)) + else (1 + (popOutTime tile)) + in Pictures + [ drawTileBack x + , Translate x 0 $ Scale curScale curScale $ Pictures $ background ++ number + ] + + +drawRow :: Row -> Picture +drawRow row = case row of + [i, j, k, l] -> + Translate + (-300) + 0 + ( Pictures + [ drawTile 0 i + , drawTile rowHgt j + , drawTile (rowHgt * 2) k + , drawTile (rowHgt * 3) l + ] + ) + _ -> Blank + + +-------------------------------------------- +-- Board handling (moving and stuff) -- +-------------------------------------------- + +toWorldFunc :: ([[Tile]] -> [[Tile]]) -> World -> World +toWorldFunc tf w = w{board = tf (board w)} + + +scootLambda :: Tile -> [Tile] -> [Tile] +scootLambda y [] = [y] +scootLambda y [x] = if val x == 0 then [x, y] else [y, x] -- TODO add animations +scootLambda y (x : xs) = if val x == 0 then x : y : xs else y : x : xs + + +-- Takes a row and scoots all numbers through zeroes *once* +-- Example: [2,0,0,2] -> [0,2,0,2] and [0,2,0,2] -> [0,0,2,2] +scootRowRightOnce :: [Tile] -> [Tile] +scootRowRightOnce = foldr scootLambda [] + + +-- does scootRight three times +scootRowRight :: [Tile] -> [Tile] +scootRowRight = scootRowRightOnce . scootRowRightOnce . scootRowRightOnce + + +-- scoots whole board +scootRight :: [[Tile]] -> [[Tile]] +scootRight = map scootRowRight + + +scoot :: Maybe Direction -> [[Tile]] -> [[Tile]] +scoot Nothing = id +scoot (Just R) = scootRight +scoot (Just U) = reverse . transpose . scootRight . transpose . reverse +scoot (Just L) = + transpose . reverse . transpose . scootRight . transpose . reverse . transpose +scoot (Just D) = transpose . scootRight . transpose + + +-------------------------------------------- +-- Comboing (TODO: REFACTOR) -- +-------------------------------------------- + +comboLambda :: Tile -> ([Tile], Int) -> ([Tile], Int) +comboLambda y ([], s) = ([y], s) +comboLambda y ((x : xs), s) = + if val x == val y && val x > 0 + then + ( (makeTile 0) : (Tile{val = val x + val y, popOutTime = 0.1, popInTime = 0}) : xs + , s + val x + val y + ) + else (y : x : xs, s) + + +-- Takes a row and does combos to the right on all numbers *once* +-- Example: [2,2,0,0] -> [0,4,0,0] and [2,2,2,2] -> [0,4,0,4] +comboRowRight :: [Tile] -> ([Tile], Int) +comboRowRight = foldr comboLambda ([], 0) + + +-- does combos on whole board +comboRight :: World -> World +-- map (comboRowRight w) (board w) => [([Tile],Int)] +comboRight w = + let (newBoard, scores) = unzip $ map comboRowRight (board w) + in w{board = newBoard, score = sum scores + score w} + + +combo :: Maybe Direction -> World -> World +combo Nothing = id +combo (Just R) = comboRight +combo (Just U) = + (toWorldFunc $ reverse . transpose) + . comboRight + . (toWorldFunc $ transpose . reverse) +combo (Just L) = + (toWorldFunc $ transpose . reverse . transpose) + . comboRight + . (toWorldFunc $ transpose . reverse . transpose) +combo (Just D) = (toWorldFunc transpose) . comboRight . (toWorldFunc transpose) + + +go :: Maybe Direction -> World -> World +go dir = (toWorldFunc $ scoot dir) . (combo dir) . (toWorldFunc $ scoot dir) diff --git a/picture/Antialiasing/Main.hs b/picture/Antialiasing/Main.hs new file mode 100644 --- /dev/null +++ b/picture/Antialiasing/Main.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Compare anti-aliased and non-anti-aliased versions of all graphical elements. +module Main where + +import Brillo + + +main :: IO () +main = + display + ( InWindow + "Anti-aliasing Comparison" + (1200, 800) + (50, 50) + ) + white + picture + + +picture :: Picture +picture = + Pictures + [ -- Column headers + Translate (-400) 350 $ Scale 0.15 0.15 $ Text "Anti-aliased" + , Translate (-150) 350 $ Scale 0.15 0.15 $ Text "Normal" + , -- Lines + Translate (-500) 280 $ Scale 0.12 0.12 $ Text "Line" + , Translate (-400) 280 $ Color blue $ Line wavyPath + , Translate (-150) 280 $ Color blue $ LineAliased wavyPath + , -- Thick Lines + Translate (-500) 220 $ Scale 0.12 0.12 $ Text "ThickLine" + , Translate (-400) 220 $ Color red $ ThickLine wavyPath 3 + , Translate (-150) 220 $ Color red $ ThickLineAliased wavyPath 3 + , -- Circles + Translate (-500) 150 $ Scale 0.12 0.12 $ Text "Circle" + , Translate (-400) 150 $ Color green $ Circle 40 + , Translate (-150) 150 $ Color green $ CircleAliased 40 + , -- Thick Circles + Translate (-500) 70 $ Scale 0.12 0.12 $ Text "ThickCircle" + , Translate (-400) 70 $ Color magenta $ ThickCircle 30 10 + , Translate (-150) 70 $ Color magenta $ ThickCircleAliased 30 10 + , -- Solid Circles + Translate (-500) (-10) $ Scale 0.12 0.12 $ Text "CircleSolid" + , Translate (-400) (-10) $ Color orange $ circleSolid 35 + , Translate (-150) (-10) $ Color orange $ circleSolidAliased 35 + , -- Arcs + Translate (-500) (-90) $ Scale 0.12 0.12 $ Text "Arc" + , Translate (-400) (-90) $ Color cyan $ Arc 30 150 40 + , Translate (-150) (-90) $ Color cyan $ ArcAliased 30 150 40 + , -- Thick Arcs + Translate (-500) (-160) $ Scale 0.12 0.12 $ Text "ThickArc" + , Translate (-400) (-160) $ Color violet $ ThickArc 30 150 30 10 + , Translate (-150) (-160) $ Color violet $ ThickArcAliased 30 150 30 10 + , -- Solid Arcs + Translate (-500) (-230) $ Scale 0.12 0.12 $ Text "ArcSolid" + , Translate (-400) (-230) $ Color rose $ arcSolid 30 150 40 + , Translate (-150) (-230) $ Color rose $ arcSolidAliased 30 150 40 + , -- Polygons (triangles) + Translate (-500) (-300) $ Scale 0.12 0.12 $ Text "Polygon" + , Translate (-400) (-300) $ Color azure $ Polygon trianglePath + , Translate (-150) (-300) $ Color azure $ PolygonAliased trianglePath + , -- Text + Translate (-500) (-370) $ Scale 0.12 0.12 $ Text "Text" + , Translate (-400) (-370) $ Color black $ Scale 0.15 0.15 $ Text "Abc" + , Translate (-150) (-370) $ Color black $ Scale 0.15 0.15 $ TextAliased "Abc" + , -- Right side: Rectangles + Translate (100) 350 $ Scale 0.15 0.15 $ Text "Anti-aliased" + , Translate (350) 350 $ Scale 0.15 0.15 $ Text "Normal" + , -- Rectangle Wire + Translate (0) 280 $ Scale 0.12 0.12 $ Text "RectWire" + , Translate (100) 280 $ Color blue $ rectangleWire 80 50 + , Translate (350) 280 $ Color blue $ rectangleWireAliased 80 50 + , -- Rectangle Solid + Translate (0) 200 $ Scale 0.12 0.12 $ Text "RectSolid" + , Translate (100) 200 $ Color green $ rectangleSolid 80 50 + , Translate (350) 200 $ Color green $ rectangleSolidAliased 80 50 + , -- Line Loop + Translate (0) 120 $ Scale 0.12 0.12 $ Text "LineLoop" + , Translate (100) 120 $ Color red $ lineLoop starPath + , Translate (350) 120 $ Color red $ lineLoopAliased starPath + , -- Sector Wire + Translate (0) 40 $ Scale 0.12 0.12 $ Text "SectorWire" + , Translate (100) 40 $ Color magenta $ sectorWire 30 120 40 + , Translate (350) 40 $ Color magenta $ sectorWireAliased 30 120 40 + , -- Thick Text + Translate (0) (-40) $ Scale 0.12 0.12 $ Text "ThickText" + , Translate (100) (-40) $ Color orange $ Scale 0.12 0.12 $ ThickText "Xyz" 5 + , Translate (350) (-40) $ + Color orange $ + Scale 0.12 0.12 $ + ThickTextAliased "Xyz" 5 + , -- Complex polygon (pentagon) + Translate (0) (-120) $ Scale 0.12 0.12 $ Text "Pentagon" + , Translate (100) (-120) $ Color cyan $ Polygon pentagonPath + , Translate (350) (-120) $ Color cyan $ PolygonAliased pentagonPath + , -- Diagonal lines (shows aliasing clearly) + Translate (0) (-200) $ Scale 0.12 0.12 $ Text "Diagonal" + , Translate (100) (-200) $ Color violet $ Line diagonalPath + , Translate (350) (-200) $ Color violet $ LineAliased diagonalPath + , -- Small circles (shows aliasing clearly) + Translate (0) (-280) $ Scale 0.12 0.12 $ Text "SmallCircles" + , Translate (100) (-280) $ smallCircles Circle + , Translate (350) (-280) $ smallCircles CircleAliased + , -- Rotated rectangle (shows aliasing on edges) + Translate (0) (-360) $ Scale 0.12 0.12 $ Text "Rotated" + , Translate (100) (-360) $ Color rose $ Rotate 30 $ rectangleSolid 70 40 + , Translate (350) (-360) $ Color rose $ Rotate 30 $ rectangleSolidAliased 70 40 + ] + + +-- | A wavy path to show line rendering +wavyPath :: Path +wavyPath = + [ (x, 15 * sin (x / 10)) + | x <- [-50, -45 .. 50] + ] + + +-- | A triangle path +trianglePath :: Path +trianglePath = [(-30, -25), (0, 30), (30, -25)] + + +-- | A star-shaped path +starPath :: Path +starPath = + [ (r * cos theta, r * sin theta) + | i <- [0 :: Int .. 4] + , let angle = fromIntegral i * 2 * pi / 5 - pi / 2 + , (r, theta) <- [(30, angle), (12, angle + pi / 5)] + ] + + +-- | A pentagon path +pentagonPath :: Path +pentagonPath = + [ (30 * cos theta, 30 * sin theta) + | i <- [0 :: Int .. 4] + , let theta = fromIntegral i * 2 * pi / 5 - pi / 2 + ] + + +-- | A diagonal line to clearly show aliasing artifacts +diagonalPath :: Path +diagonalPath = [(-40, -20), (40, 20)] + + +-- | Multiple small circles to show aliasing +smallCircles :: (Float -> Picture) -> Picture +smallCircles circFn = + Pictures + [ Translate (fromIntegral x * 15 - 30) 0 $ + Color (makeColor 0.2 0.4 0.8 1) $ + circFn (3 + fromIntegral x) + | x <- [0 .. 4 :: Int] + ] diff --git a/picture/Bitmap/Main.hs b/picture/Bitmap/Main.hs --- a/picture/Bitmap/Main.hs +++ b/picture/Bitmap/Main.hs @@ -1,6 +1,7 @@ module Main where import Brillo +import Data.Text qualified as T import System.Environment @@ -27,7 +28,7 @@ let (width, height) = bitmapSize bmpData animate - (InWindow fileName (width, height) (10, 10)) + (InWindow (T.pack fileName) (width, height) (10, 10)) black (frame width height picture) diff --git a/picture/Boids/KDTree2d.hs b/picture/Boids/KDTree2d.hs --- a/picture/Boids/KDTree2d.hs +++ b/picture/Boids/KDTree2d.hs @@ -5,7 +5,6 @@ -- module KDTree2d ( KDTreeNode (..), - newKDTree, kdtAddPoints, kdtAddPoint, kdtRangeSearch, @@ -25,11 +24,6 @@ = Empty | Node !(KDTreeNode a) !Vec2 !a !(KDTreeNode a) deriving (Show) - - --- | An empty KDTree -newKDTree :: KDTreeNode a -newKDTree = Empty -- | Flatten out a KDTree to a list. diff --git a/picture/Boids/Main.hs b/picture/Boids/Main.hs --- a/picture/Boids/Main.hs +++ b/picture/Boids/Main.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + -- Implementation of the Boids flocking algorithm. -- by Matthew Sottile -- Described in http://syntacticsalt.com/2011/03/10/functional-flocks/ @@ -15,27 +17,64 @@ -- Parameters ----------------------------------------------------------------- +cParam :: Double cParam = 0.0075 +sParam :: Double sParam = 0.1 + + +sScale :: Double sScale = 1.25 +aParam :: Double aParam = 1.0 / 1.8 + + +vLimit :: Double vLimit = 0.0025 * max (maxx - minx) (maxy - miny) + + +epsilon :: Double epsilon = 0.40 + + +maxx :: Double maxx = 8.0 + + +maxy :: Double maxy = 8.0 + + +minx :: Double minx = -8.0 + + +miny :: Double miny = -8.0 -- Colors --------------------------------------------------------------------- +boidColor :: Color boidColor = makeColor 1.0 1.0 0.0 1.0 + + +radiusColor :: Color radiusColor = makeColor 0.5 1.0 1.0 0.2 + + +cohesionColor :: Color cohesionColor = makeColor 1.0 0.0 0.0 1.0 + + +separationColor :: Color separationColor = makeColor 0.0 1.0 0.0 1.0 + + +alignmentColor :: Color alignmentColor = makeColor 0.0 0.0 1.0 1.0 @@ -75,7 +114,7 @@ } let bs = initialize 500 10.0 0.5 - let t = foldl (\t b -> kdtAddPoint t (position b) b) newKDTree bs + let t = foldl (\tree b -> kdtAddPoint tree (position b) b) Empty bs simulate (InWindow "Boids" (pixWidth w, pixHeight w) (10, 10)) @@ -115,7 +154,6 @@ renderboid world b = let (Vec2 x y) = position b (Vec2 vx vy) = velocity b - v = velocity b (Vec2 dCX dCY) = dbgC b (Vec2 dSX dSY) = dbgS b (Vec2 dAX dAY) = dbgA b @@ -146,7 +184,7 @@ -- Initialisation ------------------------------------------------------------- rnlist :: Int -> IO [Double] rnlist n = - mapM (\_ -> randomRIO (0.0, 1.0)) [1 .. n] + mapM (const $ randomRIO (0.0, 1.0)) [1 .. n] initialize :: Int -> Double -> Double -> [Boid] @@ -154,10 +192,12 @@ let nums = unsafePerformIO $ rnlist (n * 6) nums' = map (\i -> (0.5 - i) / 2.0) nums - makeboids [] [] = [] - makeboids (a : b : c : d : e : f : rest) (id : ids) = + makeboids :: [Double] -> [Int] -> [Boid] + makeboids [] _ = [] + makeboids _ [] = [] + makeboids (a : b : _c : d : e : _f : rest) (boidId : ids) = Boid - { identifier = id + { identifier = boidId , velocity = Vec2 (a * sv) (b * sv) , position = Vec2 (d * sp) (e * sp) , dbgC = vecZero @@ -165,6 +205,7 @@ , dbgA = vecZero } : makeboids rest ids + makeboids _ _ = [] in makeboids nums' [1 .. n] @@ -218,7 +259,7 @@ -- | separation: avoid neighbours separation :: Boid -> [Boid] -> Double -> Vec2 -separation b [] a = vecZero +separation _ [] _ = vecZero separation b boids a = let diff_positions = map (\i -> vecSub (position i) (position b)) boids closeby = filter (\i -> (vecNorm i) < a) diff_positions @@ -228,12 +269,12 @@ -- | alignment: fly the same way as neighbours alignment :: Boid -> [Boid] -> Double -> Vec2 -alignment b [] a = vecZero -alignment b boids a = +alignment _ [] _ = vecZero +alignment b boids _ = let v = foldl1 vecAdd (map velocity boids) s = 1.0 / (fromIntegral $ length boids) v' = vecScale v s - in vecScale (vecSub v' (velocity b)) a + in vecScale (vecSub v' (velocity b)) aParam -- | Move one boid, with respect to its neighbours. @@ -241,20 +282,20 @@ oneboid b boids = let c = cohesion b boids cParam s = separation b boids sParam - a = alignment b boids aParam + alignResult = alignment b boids aParam p = position b v = velocity b - id = identifier b - v' = vecAdd v (vecScale (vecAdd c (vecAdd s a)) 0.1) + boidId = identifier b + v' = vecAdd v (vecScale (vecAdd c (vecAdd s alignResult)) 0.1) v'' = limiter (vecScale v' 1.0025) vLimit p' = vecAdd p v'' in Boid - { identifier = id + { identifier = boidId , position = wraparound p' , velocity = v'' , dbgC = c , dbgS = s - , dbgA = a + , dbgA = alignResult } @@ -288,10 +329,10 @@ -- adjuster for wraparound adj1 ax ay (pos, theboid) = - (vecAdd pos av, theboid{position = vecAdd p av}) + (vecAdd pos av, theboid{position = vecAdd boidPos av}) where av = Vec2 ax ay - p = position theboid + boidPos = position theboid adjuster lo hi ax ay = let neighbors = kdtRangeSearch w lo hi @@ -305,9 +346,9 @@ in b : map snd (filter (\(d, _) -> d <= epsilon) dists) -splitBoxHoriz - :: (Vec2, Vec2, Double, Double) - -> [(Vec2, Vec2, Double, Double)] +splitBoxHoriz :: + (Vec2, Vec2, Double, Double) -> + [(Vec2, Vec2, Double, Double)] splitBoxHoriz (lo@(Vec2 lx ly), hi@(Vec2 hx hy), ax, ay) | hx - lx > w = [(Vec2 minx ly, Vec2 maxx hy, ax, ay)] @@ -325,9 +366,9 @@ w = maxx - minx -splitBoxVert - :: (Vec2, Vec2, Double, Double) - -> [(Vec2, Vec2, Double, Double)] +splitBoxVert :: + (Vec2, Vec2, Double, Double) -> + [(Vec2, Vec2, Double, Double)] splitBoxVert (lo@(Vec2 lx ly), hi@(Vec2 hx hy), ax, ay) | hy - ly > h = [(Vec2 lx miny, Vec2 hx maxy, ax, ay)] @@ -355,13 +396,13 @@ iteration :: ViewPort -> Float -> KDTreeNode Boid -> KDTreeNode Boid -iteration vp step w = - let all = kdtreeToList w - boids = mapKDTree w (\i -> oneboid i all) - in foldl (\t b -> kdtAddPoint t (position b) b) newKDTree boids +iteration _ _ kdtree = + let allBoids = kdtreeToList kdtree + boids = mapKDTree kdtree (\i -> oneboid i allBoids) + in foldl (\t b -> kdtAddPoint t (position b) b) Empty boids iterationkd :: ViewPort -> Float -> KDTreeNode Boid -> KDTreeNode Boid -iterationkd vp step w = - let boids = mapKDTree w (\i -> oneboid i (findNeighbors w i)) - in foldl (\t b -> kdtAddPoint t (position b) b) newKDTree boids +iterationkd _ _ kdtree = + let boids = mapKDTree kdtree (\i -> oneboid i (findNeighbors kdtree i)) + in foldl (\t b -> kdtAddPoint t (position b) b) Empty boids diff --git a/picture/CanvasEditor/Main.hs b/picture/CanvasEditor/Main.hs new file mode 100644 --- /dev/null +++ b/picture/CanvasEditor/Main.hs @@ -0,0 +1,392 @@ +{-# LANGUAGE OverloadedStrings #-} + +{-| Interactive canvas editor with draggable shapes and SVG export. + + This example demonstrates: + - Creating graphical elements (shapes) on a canvas + - Dragging shapes with the mouse + - A clickable "Export as SVG" button + - Using the file save dialog to export the canvas +-} +module Main where + +import Brillo +import Brillo.Export.SVG (exportPictureToSVG) +import Brillo.Interface.Environment (saveFileDialog) +import Brillo.Interface.IO.Game +import Control.Monad (foldM) +import Data.Maybe (listToMaybe) +import System.Directory (doesFileExist) +import System.Environment (getArgs) + + +-- | A shape on the canvas +data Shape = Shape + { shapeType :: ShapeType + , shapePos :: Point + , shapeColor :: Color + } + + +data ShapeType + = -- | Circle with radius + CircleShape Float + | -- | Rectangle with width and height + RectShape Float Float + | -- | Equilateral triangle with side length + TriangleShape Float + + +-- | Application state +data AppState = AppState + { shapes :: [Shape] + -- ^ All shapes on the canvas + , dragging :: Maybe Int + -- ^ Index of shape being dragged (if any) + , dragOffset :: Point + -- ^ Offset from shape center to mouse when drag started + , mousePos :: Point + -- ^ Current mouse position + , fontPath :: FilePath + -- ^ Path to TrueType font + } + + +-- | Layout dimensions +headerHeight :: Float +headerHeight = 50 + + +canvasWidth, canvasHeight :: Int +canvasWidth = 800 +canvasHeight = 450 + + +buttonHeight :: Float +buttonHeight = 50 + + +-- Total window height: header + canvas + button area +windowWidth, windowHeight :: Int +windowWidth = canvasWidth +windowHeight = round headerHeight + canvasHeight + round buttonHeight + 20 + + +-- Y positions (origin at center of window) +headerY :: Float +headerY = fromIntegral windowHeight / 2 - headerHeight / 2 + + +canvasY :: Float +canvasY = headerY - headerHeight / 2 - fromIntegral canvasHeight / 2 + + +buttonY :: Float +buttonY = canvasY - fromIntegral canvasHeight / 2 - buttonHeight / 2 - 10 + + +-- | Initial shapes on the canvas (positions relative to canvas center) +initialShapes :: [Shape] +initialShapes = + [ Shape (CircleShape 50) (-150, 100) red + , Shape (RectShape 80 60) (100, 50) blue + , Shape (TriangleShape 70) (0, -100) green + , Shape (CircleShape 30) (200, 150) orange + , Shape (RectShape 50 80) (-200, -50) violet + ] + + +-- | Initial application state +initialState :: FilePath -> AppState +initialState font = + AppState + { shapes = initialShapes + , dragging = Nothing + , dragOffset = (0, 0) + , mousePos = (0, 0) + , fontPath = font + } + + +-- | Convert window coordinates to canvas-local coordinates +windowToCanvas :: Point -> Point +windowToCanvas (wx, wy) = (wx, wy - canvasY) + + +-- | Convert canvas-local coordinates to window coordinates +canvasToWindow :: Point -> Point +canvasToWindow (cx, cy) = (cx, cy + canvasY) + + +-- | Check if a point (in window coords) is inside the canvas +pointInCanvas :: Point -> Bool +pointInCanvas (px, py) = + let halfW = fromIntegral canvasWidth / 2 + halfH = fromIntegral canvasHeight / 2 + cy = py - canvasY + in px >= -halfW + && px <= halfW + && cy >= -halfH + && cy <= halfH + + +-- | Check if a point (in canvas-local coords) is inside a shape +pointInShape :: Point -> Shape -> Bool +pointInShape (px, py) (Shape shapeT (sx, sy) _) = + case shapeT of + CircleShape r -> + let dx = px - sx + dy = py - sy + in dx * dx + dy * dy <= r * r + RectShape w h -> + let halfW = w / 2 + halfH = h / 2 + in px >= sx - halfW + && px <= sx + halfW + && py >= sy - halfH + && py <= sy + halfH + TriangleShape side -> + -- Approximate with bounding circle + let r = side * 0.6 + dx = px - sx + dy = py - sy + in dx * dx + dy * dy <= r * r + + +-- | Check if a point (in window coords) is inside the export button +pointInButton :: Point -> Bool +pointInButton (px, py) = + let btnWidth = 180 + halfW = btnWidth / 2 + halfH = buttonHeight / 2 + in px >= -halfW + && px <= halfW + && py >= buttonY - halfH + && py <= buttonY + halfH + + +-- | Find the topmost shape at a given point (last in list = topmost) +findShapeAt :: Point -> [Shape] -> Maybe Int +findShapeAt pt shps = + case [i | (i, s) <- zip [0 ..] shps, pointInShape pt s] of + [] -> Nothing + is -> Just (last is) + + +-- | Render a single shape +renderShape :: Shape -> Picture +renderShape (Shape shapeT (x, y) c) = + Translate x y $ + Color c $ + case shapeT of + CircleShape r -> circleSolid r + RectShape w h -> rectangleSolid w h + TriangleShape side -> + let h = side * sqrt 3 / 2 + pts = + [ (0, h * 2 / 3) + , (-side / 2, -h / 3) + , (side / 2, -h / 3) + ] + in Polygon pts + + +-- | Render the header with instructions +renderHeader :: FilePath -> Picture +renderHeader font = + Translate 0 headerY $ + Pictures + [ -- Header background (dark gray like the window background) + Color (greyN 0.8) $ + rectangleSolid (fromIntegral canvasWidth) headerHeight + , -- Instructions text + Translate (-380) (-8) $ + Color (greyN 0.3) $ + TrueTypeText + font + 20 + "Drag shapes to move them. Click the button below to export as SVG." + ] + + +-- | Render the export button +renderButton :: FilePath -> Bool -> Picture +renderButton font isHovered = + Translate 0 buttonY $ + Pictures + [ -- Button background + Color + (if isHovered then makeColor 0.3 0.6 0.9 1.0 else makeColor 0.2 0.5 0.8 1.0) + $ rectangleSolid 180 buttonHeight + , -- Button border + Color (greyN 0.2) $ rectangleWire 180 buttonHeight + , -- Button text + Translate (-70) (-8) $ + Color white $ + TrueTypeText font 22 "Export as SVG" + ] + + +-- | Render the canvas background +renderCanvas :: Picture +renderCanvas = + Translate 0 canvasY $ + Pictures + [ Color (greyN 0.95) $ + rectangleSolid (fromIntegral canvasWidth) (fromIntegral canvasHeight) + , Color (greyN 0.7) $ + rectangleWire (fromIntegral canvasWidth) (fromIntegral canvasHeight) + ] + + +-- | Render the canvas content (shapes only, for export) +renderCanvasContent :: AppState -> Picture +renderCanvasContent state = + Pictures $ map renderShape (shapes state) + + +-- | Render the entire scene +renderScene :: AppState -> IO Picture +renderScene state = do + let isHovered = pointInButton (mousePos state) + pure $ + Pictures + [ renderHeader (fontPath state) + , renderCanvas + , Translate 0 canvasY $ renderCanvasContent state + , renderButton (fontPath state) isHovered + ] + + +-- | Handle input events +handleEvent :: Event -> AppState -> IO AppState +handleEvent event state = + case event of + -- Track mouse position + EventMotion pos -> + case dragging state of + -- If dragging, update the shape position (in canvas-local coords) + Just idx -> + let (ox, oy) = dragOffset state + canvasPos = windowToCanvas pos + (mx, my) = canvasPos + newPos = (mx - ox, my - oy) + shps = shapes state + updatedShapes = updateAt idx (\s -> s{shapePos = newPos}) shps + in pure state{shapes = updatedShapes, mousePos = pos} + -- Otherwise just track mouse position + Nothing -> + pure state{mousePos = pos} + -- Mouse button down + EventKey (MouseButton LeftButton) Down _ pos -> do + -- Check if clicking the export button + if pointInButton pos + then do + exportCanvas state + pure state{mousePos = pos} + -- Check if clicking in the canvas + else + if pointInCanvas pos + then do + let canvasPos = windowToCanvas pos + case findShapeAt canvasPos (shapes state) of + Just idx -> + let (sx, sy) = shapePos (shapes state !! idx) + (mx, my) = canvasPos + offset = (mx - sx, my - sy) + in pure state{dragging = Just idx, dragOffset = offset, mousePos = pos} + Nothing -> + pure state{mousePos = pos} + else + pure state{mousePos = pos} + + -- Mouse button up - stop dragging + EventKey (MouseButton LeftButton) Up _ pos -> + pure state{dragging = Nothing, mousePos = pos} + -- Ignore other events + _ -> pure state + + +-- | Update an element at a specific index in a list +updateAt :: Int -> (a -> a) -> [a] -> [a] +updateAt idx f xs = + [if i == idx then f x else x | (i, x) <- zip [0 ..] xs] + + +-- | Export the canvas to SVG +exportCanvas :: AppState -> IO () +exportCanvas state = do + result <- + saveFileDialog + "Export as SVG" + "canvas.svg" + ["*.svg"] + "SVG files" + case result of + Nothing -> pure () -- User cancelled + Just filePath -> do + let canvasPicture = renderCanvasContent state + size = (canvasWidth, canvasHeight) + bgColor = greyN 0.95 + exportPictureToSVG size bgColor filePath canvasPicture + putStrLn $ "Exported to: " ++ filePath + + +-- | Step function (not used, but required by playIO) +stepWorld :: Float -> AppState -> IO AppState +stepWorld _ state = pure state + + +-- | Main entry point +main :: IO () +main = do + putStrLn "Canvas Editor - Drag shapes and export as SVG" + putStrLn "" + + args <- getArgs + let fontArg = listToMaybe args + font <- resolveFont fontArg + + playIO + (InWindow "Canvas Editor" (windowWidth, windowHeight) (100, 100)) + (greyN 0.8) + 60 -- 60 FPS + (initialState font) + renderScene + handleEvent + stepWorld + + +-- | Font resolution logic +resolveFont :: Maybe FilePath -> IO FilePath +resolveFont (Just fp) = pure fp +resolveFont Nothing = do + found <- foldM pick Nothing candidateFonts + case found of + Just fp -> pure fp + Nothing -> do + putStrLn + "Warning: Could not find a TrueType font. Text may not render correctly." + putStrLn "You can specify a font path as a command line argument." + pure "" + where + pick acc candidate = + case acc of + Just _ -> pure acc + Nothing -> do + exists <- doesFileExist candidate + pure $ if exists then Just candidate else Nothing + + +candidateFonts :: [FilePath] +candidateFonts = + [ "/System/Library/Fonts/Supplemental/Arial.ttf" + , "/Library/Fonts/Arial.ttf" + , "/System/Library/Fonts/Supplemental/Helvetica.ttc" + , "/System/Library/Fonts/Supplemental/Tahoma.ttf" + , "/usr/share/fonts/truetype/dejavu/DejaVuSans.ttf" + , "/usr/share/fonts/truetype/liberation/LiberationSans-Regular.ttf" + , "/usr/share/fonts/truetype/freefont/FreeSans.ttf" + , "C:\\Windows\\Fonts\\arial.ttf" + , "C:\\Windows\\Fonts\\segoeui.ttf" + ] diff --git a/picture/Chess/Main.hs b/picture/Chess/Main.hs new file mode 100644 --- /dev/null +++ b/picture/Chess/Main.hs @@ -0,0 +1,714 @@ +{-# OPTIONS_GHC -Wno-unused-top-binds #-} + +import Brillo +import Brillo.Interface.Pure.Game +import Data.Map.Strict qualified as Map +import Data.Maybe (catMaybes, fromJust, isJust, isNothing) +import Data.Text qualified as T + + +{- Chess game between two human players on a single computere. + Game rules is verified durint play, but draw and checkmate is not detected. + Compile: ghc -O2 Chess.hs + Optimize: strip Chess -o ChessStrip + Run: ./Chess -} + +main :: IO () +main = do + let + boardWidth = 500 + maxTime = 900 + play + (InWindow (T.pack "Haskell Chess") (600, 650) (0, 0)) + (makeColorI 180 120 70 255) -- Wood brown background + 5 + (initialState maxTime) + (drawWorld boardWidth) + (handleEvent boardWidth) + stepWorld + + +type BoardWidth = Float +type Board = Map.Map Pos Piece +type Pos = (Int, Int) -- (col, row) +data PColor = White | Black deriving (Eq, Show) +data PType = King | Rook | Bishop | Queen | Knight | Pawn deriving (Eq, Show) +data PState = Init | TwoStep | Moved deriving (Eq, Show) +data Piece = Piece + { ptype :: PType + , pcolor :: PColor + , pstate :: PState + } + deriving (Eq, Show) +data Marker = Marker + { position :: Pos + , selected :: Maybe Pos + , invalid :: Maybe Pos + } +data Player = Player + { name :: T.Text -- Not yet used + , timeLeft :: Float + , col :: PColor -- Not yet used + , captured :: [Piece] -- Not yet used + } +data State = State + { board :: Board + , marker :: Marker + , whitePlayer :: Player + , blackPlayer :: Player + , current :: PColor + , message :: T.Text + } + + +tBlue :: Color +tBlue = makeColorI 70 110 180 255 + + +tGreen :: Color +tGreen = makeColorI 80 160 80 255 + + +tRed :: Color +tRed = makeColorI 180 60 60 255 + + +-- Helpers to handle pieces on the board +setPiece :: Pos -> Piece -> Board -> Board +setPiece = Map.insert + + +updatePiece :: (Piece -> Piece) -> Pos -> Board -> Board +updatePiece = Map.adjust + + +getPiece :: Pos -> Board -> Maybe Piece +getPiece = Map.lookup + + +dropPiece :: Pos -> Board -> Board +dropPiece = Map.delete + + +movePiece :: Pos -> Pos -> Board -> Board +movePiece from to b = setPiece to p $ dropPiece from b + where + p = fromJust $ getPiece from b + + +setMarker :: Pos -> State -> State +setMarker p s = s{marker = (marker s){position = p, invalid = Nothing}} + + +setMessage :: T.Text -> State -> State +setMessage m s = s{message = m} + + +-- Set selected if marker is on a valid piece +setSelected :: Maybe Pos -> State -> State +setSelected Nothing s = s{marker = (marker s){selected = Nothing, invalid = Nothing}} +setSelected (Just p) s = if valid then sValid else sInvalid + where + piece = getPiece p (board s) + valid = isJust piece && (pcolor (fromJust piece) == current s) + hasPiece = isJust piece + sValid = s{marker = (marker s){selected = Just p, invalid = Nothing}} + sInvalid = s{marker = (marker s){invalid = if hasPiece then Just p else Nothing}} + + +-- Move pos marker, but make sure move is not outside board +movePos :: Pos -> SpecialKey -> Pos +movePos (a, b) KeyLeft = if (a > 0) then (a - 1, b) else (a, b) +movePos (a, b) KeyRight = if (a < 7) then (a + 1, b) else (a, b) +movePos (a, b) KeyUp = if (b > 0) then (a, b - 1) else (a, b) +movePos (a, b) KeyDown = if (b < 7) then (a, b + 1) else (a, b) +movePos p _ = p + + +-- Move piece according to marker position if valid move. Assumes that a piece has been selected +-- This happen when the user has selected a piece and drop it on a new location +drawPiece :: State -> State +drawPiece s + | (isNothing b') = + setMessage + (T.pack "Invalid") + s{marker = (marker s){invalid = Just (position $ marker s)}} + | (isCheck s') = setMessage (T.pack "Check") s + | otherwise = setMessage (T.pack "") $ stepCurrent s' + where + b = board s + b' = stepBoard b + s' = s{board = fromJust b'} + + -- Update board state if possible + stepBoard :: Board -> Maybe Board + stepBoard _boardState + | isEnPassant = Just $ movePiece p0 p1 $ dropPiece (fst p1, snd p0) b + | isPromotion = Just $ movePiece p0 p1 $ updatePiece (promotePiece Queen) p0 b + | isCapture = Just $ movePiece p0 p1 $ updatePiece (stepPState p0 p1) p0 b + | isCastling = + let (r0, r1) = castlingRookMove (p0, p1) + in Just $ movePiece r0 r1 $ movePiece p0 p1 b + | isMove = Just $ movePiece p0 p1 $ updatePiece (stepPState p0 p1) p0 b + | otherwise = Nothing + + (p0, p1) = (fromJust $ selected $ marker s, position $ marker s) + piece = fromJust $ getPiece p0 b + capture = getPiece p1 b + isValid = + (pcolor piece == current s) + && (distance p0 p1 > 0) + && (isJust $ getPiece p0 b) + isPathClear = pathClear b p0 p1 piece + isMove = + isValid + && isPathClear + && (isNothing $ getPiece p1 b) + && (validMove piece p0 p1) + isCapture = + isValid + && isPathClear + && (isJust $ capture) + && (pcolor $ fromJust $ capture) /= (current s) + && (validCapture piece p0 p1) + isEnPassant = + let cpawn = getPiece (fst p1, snd p0) b + in (isJust cpawn) + && ((pstate $ fromJust cpawn) == TwoStep) -- there's a piece to capture + && (validCapture piece p0 p1) -- there's a pawm that has moved TwoStep + isPromotion = + (isMove || isCapture) + && (ptype piece == Pawn) + && (snd p1 == 0 || snd p1 == 7) -- it's a pawn + -- move is to final line + isCastling = + let (r0, _r1) = castlingRookMove (p0, p1) + rook = getPiece r0 b + in isValid + && (pathClear b p0 r0 piece) + && (ptype piece == King) -- check that path is clear + && (pstate piece == Init) -- check that piece is the king + && (isJust $ rook) -- check that king has not moved + && ((pstate $ fromJust rook) == Init) -- check that rook has not moved + && (fst p1 == 2 || fst p1 == 6) -- check that target square is correct + + +-- Check if a move from p0 to p1 is valid on the given board for the given color +canMove :: Board -> PColor -> Pos -> Pos -> Bool +canMove b cur p0 p1 = + case getPiece p0 b of + Nothing -> False + Just piece -> + let capture = getPiece p1 b + isValid = + (pcolor piece == cur) + && (distance p0 p1 > 0) + isPathClear = pathClear b p0 p1 piece + isAMove = + isValid + && isPathClear + && isNothing capture + && validMove piece p0 p1 + isCapture = + isValid + && isPathClear + && isJust capture + && pcolor (fromJust capture) /= cur + && validCapture piece p0 p1 + isEnPassant = + let cpawn = getPiece (fst p1, snd p0) b + in isJust cpawn + && (pstate (fromJust cpawn) == TwoStep) + && validCapture piece p0 p1 + isCastling = + let (r0, _r1) = castlingRookMove (p0, p1) + rook = getPiece r0 b + in isValid + && pathClear b p0 r0 piece + && ptype piece == King + && pstate piece == Init + && isJust rook + && (pstate (fromJust rook) == Init) + && (fst p1 == 2 || fst p1 == 6) + in isAMove || isCapture || isEnPassant || isCastling + + +-- Get rook move from king move in castling +castlingRookMove :: (Pos, Pos) -> (Pos, Pos) +castlingRookMove (p0, p1) = + let r = snd p0 + in if (fst p0 < fst p1) + then ((7, r), (5, r)) + else ((0, r), (3, r)) + + +-- Step PState according to move from a to b +stepPState :: Pos -> Pos -> Piece -> Piece +stepPState a b p = + if (ptype p == Pawn && distance a b == 2) + then p{pstate = TwoStep} + else p{pstate = Moved} + + +-- Board distance in number of (diagonal or horizontal steps +distance :: Pos -> Pos -> Int +distance (c0, r0) (c1, r1) = max (abs $ c1 - c0) (abs $ r1 - r0) + + +-- Check that board is clear between two board positions (either horizontal or diagonal) +pathClear :: Board -> Pos -> Pos -> Piece -> Bool +pathClear b (c0, r0) (c1, r1) p + | (ptype p == Knight) = True + | (d > 1) = (length blockers) == 0 + | otherwise = True + where + d = distance (c0, r0) (c1, r1) + (sc, sr) = ((c1 - c0) `div` d, (r1 - r0) `div` d) + ps = map (\s -> (c0 + (sc * s), r0 + (sr * s))) [1 .. (d - 1)] + blockers = catMaybes $ map (`getPiece` b) ps + + +-- Check if move piece from a to b is a valid move (assuming an empty board) +validMove :: Piece -> Pos -> Pos -> Bool +validMove (Piece King _ _) (c0, r0) (c1, r1) = abs (c1 - c0) <= 1 && abs (r1 - r0) <= 1 +validMove (Piece Rook _ _) (c0, r0) (c1, r1) = (c1 - c0) == 0 || (r1 - r0) == 0 +validMove (Piece Bishop _ _) (c0, r0) (c1, r1) = abs (c1 - c0) == abs (r1 - r0) +validMove (Piece Queen _ _) p0 p1 = + validMove (Piece Rook Black Init) p0 p1 + || validMove (Piece Bishop Black Init) p0 p1 +validMove (Piece Knight _ _) (c0, r0) (c1, r1) = + let (dc, dr) = (abs (c1 - c0), abs (r1 - r0)) + in (dc == 1 && dr == 2) || (dc == 2 && dr == 1) +validMove (Piece Pawn Black _) (c0, r0) (c1, r1) = (c1 - c0) == 0 && ((r1 - r0) == 1 || ((r1 - r0) == 2 && r0 == 1)) +validMove (Piece Pawn White _) (c0, r0) (c1, r1) = (c1 - c0) == 0 && ((r0 - r1) == 1 || ((r0 - r1) == 2 && r0 == 6)) + + +validCapture :: Piece -> Pos -> Pos -> Bool +validCapture (Piece Pawn Black _) (c0, r0) (c1, r1) = (r1 - r0) == 1 && abs (c1 - c0) == 1 +validCapture (Piece Pawn White _) (c0, r0) (c1, r1) = (r0 - r1) == 1 && abs (c1 - c0) == 1 +validCapture p p0 p1 = validMove p p0 p1 + + +-- Determine if current player is checked. Assumes that the king exist for cur player +isCheck :: State -> Bool +isCheck s = not $ Map.null checkers + where + b = board s + c = current s + kingPositions = + Map.keys + $ Map.filter + ( \p -> + ((ptype p) == King) + && ((pcolor p) == c) + ) + $ b + kingPos = case kingPositions of + (k : _) -> k + [] -> (0, 0) -- Should never happen in a valid game + checkers = + Map.filterWithKey + ( \checkerPos p -> + (pcolor p /= c) + && (pathClear b checkerPos kingPos p) + && (validCapture p checkerPos kingPos) + ) + $ b + + +-- Change current player and clear marker and +stepCurrent :: State -> State +stepCurrent s = + s + { marker = (marker s){selected = Nothing, invalid = Nothing} + , current = opposite (current s) + } + where + opposite col = if col == Black then White else Black + + +promotePiece :: PType -> Piece -> Piece +promotePiece new p = p{ptype = new} + + +-- Draw the scene +drawWorld :: BoardWidth -> State -> Picture +drawWorld bw s = + Translate (-bw * 0.5) (-bw * 0.55) $ + Pictures $ + [ drawBoard bw + , drawPieces bw (board s) + , drawMarker bw s + , drawSelected bw (marker s) + , drawInvalid bw (marker s) + , drawState bw s + ] + + +-- Draw board with bottom left corner in origo +drawBoard :: BoardWidth -> Picture +drawBoard w = + let + tup a b = (a, b) + sqAt (c, r) = Translate c r $ rectangleSolid 1 1 + blackSquares = + (tup <$> [0, 2, 4, 6] <*> [0, 2, 4, 6]) + ++ (tup <$> [1, 3, 5, 7] <*> [1, 3, 5, 7]) + whiteSquares = + (tup <$> [1, 3, 5, 7] <*> [0, 2, 4, 6]) + ++ (tup <$> [0, 2, 4, 6] <*> [1, 3, 5, 7]) + border = Translate 3.5 3.5 $ rectangleWire 8 8 + in + Scale (w / 8) (w / 8) $ + Translate 0.5 0.5 $ + Pictures $ + [ Color white $ Pictures (map sqAt whiteSquares) + , Color (greyN 0.5) $ Pictures (map sqAt blackSquares) + , border + ] + + +drawPieces :: BoardWidth -> Board -> Picture +drawPieces bw b = + Translate (bw / 16) (bw / 16) $ + Pictures $ + Map.elems $ + Map.mapWithKey (\pos p -> toPic pos p) b + where + toPic :: Pos -> Piece -> Picture + toPic pos p = + let (tx, ty) = translatePos bw $ pos + in Translate tx ty $ pieceGfx p + + +-- Draw marker +drawMarker :: BoardWidth -> State -> Picture +drawMarker bw s = + let pos = position $ marker s + (tx, ty) = translatePos bw pos + piece = getPiece pos (board s) + isEnemy = case piece of + Just p -> pcolor p /= current s + Nothing -> False + sel = selected $ marker s + noSelection = isNothing sel + invalidMove = case sel of + Just from -> pos /= from && not (canMove (board s) (current s) from pos) + Nothing -> False + col + | isEnemy && noSelection = tRed + | noSelection && isNothing piece = makeColorI 140 90 50 255 + | invalidMove = tRed + | otherwise = tGreen + ring = Color col $ Translate tx ty $ ThickCircle 27 6 + in Translate (bw / 16) (bw / 16) $ ring + + +-- Draw selected +drawSelected :: BoardWidth -> Marker -> Picture +drawSelected bw m = + let sel = selected m + (tx, ty) = translatePos bw $ maybe (0, 0) id sel + selector = Color tBlue $ Translate tx ty $ ThickCircle 27 6 + in if (isJust sel) + then Translate (bw / 16) (bw / 16) $ selector + else Blank + + +-- Draw invalid selection +drawInvalid :: BoardWidth -> Marker -> Picture +drawInvalid bw m = + let inv = invalid m + (tx, ty) = translatePos bw $ maybe (0, 0) id inv + ring = Color tRed $ Translate tx ty $ ThickCircle 27 6 + in if (isJust inv) + then Translate (bw / 16) (bw / 16) $ ring + else Blank + + +-- Translete to a board position, assuming that center of bottom, left square is in origo +translatePos :: BoardWidth -> Pos -> (Float, Float) +translatePos bw (c, r) = ((bw / 8) * fromIntegral c, (bw / 8) * fromIntegral (7 - r)) + + +-- Draw current player state +drawState :: BoardWidth -> State -> Picture +drawState bw s = + let + col = case (current s) of + Black -> black + White -> white + pCurrent = + Translate (0.5 * bw) (1.1 * bw) $ + Pictures + [ Color col $ rectangleSolid (bw / 16) (bw / 16) + , Color black $ rectangleWire (bw / 16) (bw / 16) + ] + tWhite = round (timeLeft . whitePlayer $ s) :: Integer + tBlack = round (timeLeft . blackPlayer $ s) :: Integer + pWhite = + Color (timeColor tWhite) $ + Translate (0.3 * bw) (1.075 * bw) $ + Scale 0.2 0.2 $ + Text $ + T.pack $ + secFormatted $ + tWhite + pBlack = + Color (timeColor tBlack) $ + Translate (0.56 * bw) (1.075 * bw) $ + Scale 0.2 0.2 $ + Text $ + T.pack $ + secFormatted $ + tBlack + secFormatted sec = show (sec `div` 60) ++ ":" ++ show (sec `mod` 60) + timeColor sec = if (sec < 0) then red else black + pMessage = + Color black $ + Translate (0.05 * bw) ((-0.06) * bw) $ + Scale 0.15 0.15 $ + Text $ + message s + in + Pictures $ [pCurrent, pWhite, pBlack, pMessage] + + +initialState :: Float -> State +initialState timeLeft = + State + (Map.fromList board) + marker + whitePlayer + blackPlayer + White + (T.pack "Arrows/Click: Move | Space/Click: Select") + where + asBlack t = Piece t Black Init + asWhite t = Piece t White Init + atRow r c = (c, r) + r0 = [Rook, Knight, Bishop, Queen, King, Bishop, Knight, Rook] + r1 = [Pawn, Pawn, Pawn, Pawn, Pawn, Pawn, Pawn, Pawn] + board = + zip (map (atRow 0) [0 .. 7]) (map asBlack r0) + ++ zip (map (atRow 1) [0 .. 7]) (map asBlack r1) + ++ zip (map (atRow 6) [0 .. 7]) (map asWhite r1) + ++ zip (map (atRow 7) [0 .. 7]) (map asWhite r0) + marker = Marker (0, 0) Nothing Nothing + blackPlayer = Player (T.pack "Black Player") timeLeft Black [] + whitePlayer = Player (T.pack "White Player") timeLeft White [] + + +-- Convert world-space click coordinates to board position +pixelToBoard :: BoardWidth -> (Float, Float) -> Maybe Pos +pixelToBoard bw (mx, my) = + let col = floor ((mx + bw * 0.5) / (bw / 8)) + row = 7 - floor ((my + bw * 0.55) / (bw / 8)) + in if col >= 0 && col <= 7 && row >= 0 && row <= 7 + then Just (col, row) + else Nothing + + +handleEvent :: BoardWidth -> Event -> State -> State +handleEvent _ (EventKey (SpecialKey KeyUp) Down _ _) s = setMarker (movePos (position . marker $ s) KeyUp) s +handleEvent _ (EventKey (SpecialKey KeyDown) Down _ _) s = setMarker (movePos (position . marker $ s) KeyDown) s +handleEvent _ (EventKey (SpecialKey KeyLeft) Down _ _) s = setMarker (movePos (position . marker $ s) KeyLeft) s +handleEvent _ (EventKey (SpecialKey KeyRight) Down _ _) s = setMarker (movePos (position . marker $ s) KeyRight) s +handleEvent _ (EventKey (SpecialKey KeySpace) Down _ _) s -- Space toggle selection, or draw piece + | isNothing sel = setSelected (Just pos) s + | pos == fromJust sel = setSelected Nothing s + | otherwise = drawPiece s + where + sel = selected . marker $ s + pos = position . marker $ s +handleEvent bw (EventKey (MouseButton LeftButton) Down _ clickPos) s + | Just p <- pixelToBoard bw clickPos = + let s' = setMarker p s + sel = selected . marker $ s' + in if isNothing sel + then setSelected (Just p) s' + else + if p == fromJust sel + then setSelected Nothing s' + else drawPiece s' +handleEvent _ _ s = s + + +stepWorld :: Float -> State -> State +stepWorld dt s@(State _ _ w _ White _) = s{whitePlayer = w{timeLeft = (timeLeft w - dt)}} +stepWorld dt s@(State _ _ _ b Black _) = s{blackPlayer = b{timeLeft = (timeLeft b - dt)}} + + +-- Drawn chess piece graphics +pieceGfx :: Piece -> Picture +pieceGfx (Piece t c _) = + let + fill = case c of + White -> greyN 0.9 + Black -> greyN 0.15 + outline = case c of + White -> greyN 0.2 + Black -> greyN 0.7 + in + case t of + Pawn -> pawnPic fill outline + Rook -> rookPic fill outline + Knight -> knightPic fill outline + Bishop -> bishopPic fill outline + Queen -> queenPic fill outline + King -> kingPic fill outline + + +-- Draw a filled polygon with a border via offset copies +borderedPoly :: Color -> Color -> [Point] -> Picture +borderedPoly fill bord pts = + Pictures + [ Color bord $ + Pictures + [Translate dx dy $ Polygon pts | dx <- [-1, 0, 1], dy <- [-1, 0, 1]] + , Color fill $ Polygon pts + ] + + +-- Draw a filled circle with a border +borderedCircle :: Color -> Color -> Float -> Picture +borderedCircle fill bord r = + Pictures + [ Color bord $ circleSolid (r + 1.5) + , Color fill $ circleSolid r + ] + + +pawnPic :: Color -> Color -> Picture +pawnPic f o = + Pictures + [ borderedPoly + f + o + [ (-4, 3) + , (-8, -8) + , (-10, -13) + , (-10, -15) + , (10, -15) + , (10, -13) + , (8, -8) + , (4, 3) + ] + , Translate 0 8 $ borderedCircle f o 6 + ] + + +rookPic :: Color -> Color -> Picture +rookPic f o = + borderedPoly + f + o + [ (-11, -15) + , (-11, -10) + , (-8, -10) + , (-8, 8) + , (-11, 8) + , (-11, 15) + , (-7, 15) + , (-7, 11) + , (-2, 11) + , (-2, 15) + , (2, 15) + , (2, 11) + , (7, 11) + , (7, 15) + , (11, 15) + , (11, 8) + , (8, 8) + , (8, -10) + , (11, -10) + , (11, -15) + ] + + +knightPic :: Color -> Color -> Picture +knightPic f o = + borderedPoly + f + o + [ (-6, -15) + , (-6, 0) + , (-8, 6) + , (-6, 10) + , (-2, 14) + , (2, 15) + , (6, 12) + , (8, 6) + , (10, 2) + , (8, -2) + , (4, 0) + , (6, -8) + , (8, -15) + ] + + +bishopPic :: Color -> Color -> Picture +bishopPic f o = + Pictures + [ borderedPoly + f + o + [ (0, 14) + , (-6, 4) + , (-9, -6) + , (-10, -13) + , (-10, -15) + , (10, -15) + , (10, -13) + , (9, -6) + , (6, 4) + ] + , Translate 0 17 $ borderedCircle f o 3 + ] + + +queenPic :: Color -> Color -> Picture +queenPic f o = + borderedPoly + f + o + [ (-11, -15) + , (-9, -6) + , (-7, 0) + , (-11, 10) + , (-6, 6) + , (-3, 13) + , (0, 8) + , (3, 13) + , (6, 6) + , (11, 10) + , (7, 0) + , (9, -6) + , (11, -15) + ] + + +kingPic :: Color -> Color -> Picture +kingPic f o = + Pictures + [ borderedPoly + f + o + [ (-10, -15) + , (-9, -8) + , (-7, 0) + , (-6, 8) + , (6, 8) + , (7, 0) + , (9, -8) + , (10, -15) + ] + , borderedPoly + f + o + [(-1.5, 8), (-1.5, 20), (1.5, 20), (1.5, 8)] + , borderedPoly + f + o + [(-5, 14), (-5, 17), (5, 17), (5, 14)] + ] diff --git a/picture/CircleComparison/Main.hs b/picture/CircleComparison/Main.hs new file mode 100644 --- /dev/null +++ b/picture/CircleComparison/Main.hs @@ -0,0 +1,312 @@ +{-# LANGUAGE OverloadedStrings #-} + +{-| Comprehensive comparison of anti-aliased vs aliased circle rendering. + +This example tests various edge cases to identify rendering artifacts: +- Very small circles (sub-pixel to a few pixels) +- Very large circles +- Circles at different zoom levels +- Various thickness values +- Overlapping/adjacent circles +- Circles with different colors and alpha +- Rotated/translated circles +- Arcs with various angle ranges +-} +module Main where + +import Brillo +import Brillo.Interface.Pure.Game +import Data.Text qualified as T + + +main :: IO () +main = + play + ( InWindow + "Circle Comparison - Anti-aliased vs Aliased" + (1400, 900) + (50, 50) + ) + white + 60 + initialWorld + drawWorld + handleEvent + stepWorld + + +-- | World state with zoom and pan +data World = World + { worldZoom :: !Float + , worldPanX :: !Float + , worldPanY :: !Float + } + + +initialWorld :: World +initialWorld = World 1.0 0 0 + + +stepWorld :: Float -> World -> World +stepWorld _ = id + + +handleEvent :: Event -> World -> World +handleEvent event world = case event of + -- Zoom with scroll wheel or +/- + EventKey (SpecialKey KeyUp) Down _ _ -> + world{worldZoom = worldZoom world * 1.2} + EventKey (SpecialKey KeyDown) Down _ _ -> + world{worldZoom = worldZoom world / 1.2} + EventKey (Char '+') Down _ _ -> + world{worldZoom = worldZoom world * 1.2} + EventKey (Char '-') Down _ _ -> + world{worldZoom = worldZoom world / 1.2} + EventKey (Char '=') Down _ _ -> + world{worldZoom = worldZoom world * 1.2} + -- Pan with arrow keys + EventKey (SpecialKey KeyLeft) Down _ _ -> + world{worldPanX = worldPanX world + 50} + EventKey (SpecialKey KeyRight) Down _ _ -> + world{worldPanX = worldPanX world - 50} + -- Reset with 'r' + EventKey (Char 'r') Down _ _ -> initialWorld + _ -> world + + +drawWorld :: World -> Picture +drawWorld world = + Pictures + [ -- Instructions at top + Translate (-680) 420 $ + Scale 0.1 0.1 $ + Text "Up/Down or +/-: Zoom | Left/Right: Pan | R: Reset" + , Translate (-680) 390 $ + Scale 0.1 0.1 $ + Text $ + T.pack $ + "Zoom: " ++ show (worldZoom world) + , -- Apply zoom and pan to test content + Translate (worldPanX world) (worldPanY world) $ + Scale (worldZoom world) (worldZoom world) $ + testContent + ] + + +testContent :: Picture +testContent = + Pictures + [ -- Section 1: Size comparison (very small to large) + sizeComparisonSection + , -- Section 2: Thickness variations + thicknessSection + , -- Section 3: Arc angle variations + arcSection + , -- Section 4: Adjacent/overlapping circles + adjacentSection + , -- Section 5: Alpha/transparency + alphaSection + , -- Section 6: Stress test grid + gridSection + ] + + +-- | Compare circles of various sizes +sizeComparisonSection :: Picture +sizeComparisonSection = + Translate (-550) 280 $ + Pictures + [ -- Header + Translate 0 70 $ Scale 0.12 0.12 $ Text "Size Comparison" + , Translate 0 50 $ Scale 0.08 0.08 $ Text "Anti-aliased (top) vs Aliased (bottom)" + , -- Row of circles with increasing sizes + Pictures + [ let xPos = fromIntegral i * 70 + radius = sizes !! i + in Pictures + [ -- Anti-aliased + Translate xPos 20 $ Color blue $ circleSolid radius + , -- Aliased + Translate xPos (-30) $ Color blue $ circleSolidAliased radius + , -- Size label + Translate xPos (-60) $ + Scale 0.06 0.06 $ + Text (T.pack $ show radius ++ "px") + ] + | i <- [0 .. length sizes - 1] + ] + ] + where + sizes = [0.5, 1, 2, 3, 5, 8, 15, 25, 40] + + +-- | Compare circles with various thicknesses +thicknessSection :: Picture +thicknessSection = + Translate (-550) 130 $ + Pictures + [ -- Header + Translate 0 70 $ Scale 0.12 0.12 $ Text "Thickness Variations" + , -- Row of thick circles + Pictures + [ let xPos = fromIntegral i * 90 + thickness = thicknesses !! i + in Pictures + [ -- Anti-aliased + Translate xPos 20 $ Color red $ ThickCircle 25 thickness + , -- Aliased + Translate xPos (-40) $ Color red $ ThickCircleAliased 25 thickness + , -- Thickness label + Translate xPos (-80) $ + Scale 0.06 0.06 $ + Text (T.pack $ "t=" ++ show thickness) + ] + | i <- [0 .. length thicknesses - 1] + ] + ] + where + thicknesses = [1, 2, 5, 10, 20, 30, 50] + + +-- | Compare arcs with various angle ranges +arcSection :: Picture +arcSection = + Translate (-550) (-40) $ + Pictures + [ -- Header + Translate 0 70 $ Scale 0.12 0.12 $ Text "Arc Angle Variations" + , -- Row of arcs + Pictures + [ let xPos = fromIntegral i * 100 + (a1, a2) = angles !! i + in Pictures + [ -- Anti-aliased + Translate xPos 15 $ Color green $ arcSolid a1 a2 30 + , -- Aliased + Translate xPos (-50) $ Color green $ arcSolidAliased a1 a2 30 + , -- Angle label + Translate xPos (-90) $ + Scale 0.05 0.05 $ + Text (T.pack $ show (round a1 :: Int) ++ "-" ++ show (round a2 :: Int)) + ] + | i <- [0 .. length angles - 1] + ] + ] + where + angles = + [ (0, 30) -- Small arc + , (0, 90) -- Quarter + , (0, 180) -- Half + , (0, 270) -- Three-quarter + , (0, 359) -- Almost full + , (45, 135) -- Arbitrary + , (-45, 45) -- Crossing 0 + ] + + +-- | Test adjacent and overlapping circles +adjacentSection :: Picture +adjacentSection = + Translate (200) 280 $ + Pictures + [ -- Header + Translate 0 70 $ Scale 0.12 0.12 $ Text "Adjacent/Overlapping" + , -- Adjacent circles (normal) + Translate (-80) 0 $ + Pictures + [ Translate (-20) 0 $ Color orange $ circleSolid 20 + , Translate 20 0 $ Color orange $ circleSolid 20 + ] + , -- Adjacent circles (smooth) + Translate (80) 0 $ + Pictures + [ Translate (-20) 0 $ Color orange $ circleSolidAliased 20 + , Translate 20 0 $ Color orange $ circleSolidAliased 20 + ] + , -- Labels + Translate (-80) (-40) $ Scale 0.06 0.06 $ Text "Anti-aliased" + , Translate 80 (-40) $ Scale 0.06 0.06 $ Text "Aliased" + , -- Overlapping circles (normal) + Translate (-80) (-80) $ + Pictures + [ Translate (-10) 0 $ Color (withAlpha 0.7 cyan) $ circleSolid 20 + , Translate 10 0 $ Color (withAlpha 0.7 magenta) $ circleSolid 20 + ] + , -- Overlapping circles (smooth) + Translate (80) (-80) $ + Pictures + [ Translate (-10) 0 $ Color (withAlpha 0.7 cyan) $ circleSolidAliased 20 + , Translate 10 0 $ Color (withAlpha 0.7 magenta) $ circleSolidAliased 20 + ] + ] + + +-- | Test alpha/transparency rendering +alphaSection :: Picture +alphaSection = + Translate (200) 100 $ + Pictures + [ -- Header + Translate 0 70 $ Scale 0.12 0.12 $ Text "Alpha Transparency" + , -- Background rectangle + Color (greyN 0.8) $ rectangleSolid 200 100 + , -- Anti-aliased with various alphas + Translate (-60) 0 $ + Pictures + [ Translate 0 20 $ Color (withAlpha 1.0 red) $ circleSolid 15 + , Translate 0 0 $ Color (withAlpha 0.7 red) $ circleSolid 15 + , Translate 0 (-20) $ Color (withAlpha 0.3 red) $ circleSolid 15 + ] + , -- Aliased with various alphas + Translate 60 0 $ + Pictures + [ Translate 0 20 $ Color (withAlpha 1.0 red) $ circleSolidAliased 15 + , Translate 0 0 $ Color (withAlpha 0.7 red) $ circleSolidAliased 15 + , Translate 0 (-20) $ Color (withAlpha 0.3 red) $ circleSolidAliased 15 + ] + , -- Labels + Translate (-60) (-55) $ Scale 0.06 0.06 $ Text "Anti-aliased" + , Translate 60 (-55) $ Scale 0.06 0.06 $ Text "Aliased" + ] + + +-- | Grid of small circles to stress test at various zoom levels +gridSection :: Picture +gridSection = + Translate (450) (-100) $ + Pictures + [ -- Header + Translate 0 140 $ Scale 0.12 0.12 $ Text "Stress Test Grid" + , Translate 0 120 $ Scale 0.07 0.07 $ Text "Zoom in/out to test edge cases" + , -- Anti-aliased grid + Translate (-100) 0 $ + Pictures + [ Translate 0 (-120) $ Scale 0.06 0.06 $ Text "Anti-aliased" + , circleGrid circleSolid + ] + , -- Aliased grid + Translate 100 0 $ + Pictures + [ Translate 0 (-120) $ Scale 0.06 0.06 $ Text "Aliased" + , circleGrid circleSolidAliased + ] + ] + + +-- | Create a grid of small circles +circleGrid :: (Float -> Picture) -> Picture +circleGrid circleFn = + Pictures + [ Translate (fromIntegral x * spacing) (fromIntegral y * spacing) $ + Color (makeColor r g b 1) $ + circleFn radius + | x <- [-gridSize .. gridSize] + , y <- [-gridSize .. gridSize] + , let radius = 3 + fromIntegral (abs x + abs y) * 0.3 + r = 0.3 + 0.1 * fromIntegral x / fromIntegral gridSize + g = 0.3 + 0.1 * fromIntegral y / fromIntegral gridSize + b = 0.8 + ] + where + gridSize = 5 :: Int + spacing = 18 :: Float diff --git a/picture/Clock/Main.hs b/picture/Clock/Main.hs --- a/picture/Clock/Main.hs +++ b/picture/Clock/Main.hs @@ -1,8 +1,11 @@ +{-# LANGUAGE OverloadedStrings #-} + -- A fractal consisting of circles and lines which looks a bit like -- the workings of a clock. module Main where import Brillo +import Data.Text qualified as T import Prelude hiding (lines) @@ -58,14 +61,14 @@ -- circNm1 = Pictures - [ circle 1 + [ Circle 1 , Scale (a / 2.5) (a / 2.5) $ clockFractal (n - 1) s , if n > 2 then Color cyan $ Translate (-0.15) 1 $ Scale 0.001 0.001 $ - Text (show s) + Text (T.pack $ show s) else Blank ] diff --git a/picture/Color/Main.hs b/picture/Color/Main.hs --- a/picture/Color/Main.hs +++ b/picture/Color/Main.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ParallelListComp #-} -- Draw a color wheel. diff --git a/picture/Conway/Cell.hs b/picture/Conway/Cell.hs --- a/picture/Conway/Cell.hs +++ b/picture/Conway/Cell.hs @@ -54,12 +54,12 @@ {-| Standard Hot -> Cold hypsometric color ramp. Sequence is red, yellow, green, cyan, blue. -} -rampColorHotToCold - :: (Ord a, Floating a) - => a - -> a - -> a - -> (a, a, a) +rampColorHotToCold :: + (Ord a, Floating a) => + a -> + a -> + a -> + (a, a, a) rampColorHotToCold vmin vmax vNotNorm = let v diff --git a/picture/Conway/Main.hs b/picture/Conway/Main.hs --- a/picture/Conway/Main.hs +++ b/picture/Conway/Main.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + module Main where import Brillo @@ -27,9 +29,9 @@ -- | Convert a world to a picture. -drawWorld - :: World - -> Picture +drawWorld :: + World -> + Picture drawWorld world = let (windowWidth, windowHeight) = windowSizeOfWorld world diff --git a/picture/Cursors/Main.hs b/picture/Cursors/Main.hs new file mode 100644 --- /dev/null +++ b/picture/Cursors/Main.hs @@ -0,0 +1,238 @@ +{-# LANGUAGE OverloadedStrings #-} + +{-| Cursor demo showing all available cursor shapes. + Hover over each button to see the corresponding cursor. +-} +module Main where + +import Brillo +import Brillo.Interface.IO.Interact +import Control.Monad (foldM) +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import Data.List (isPrefixOf) +import Data.Maybe (listToMaybe) +import Data.Text qualified as T +import System.Directory (doesFileExist) +import System.Environment (getArgs) +import System.Exit (exitFailure) +import System.IO (hPutStrLn, stderr) + + +main :: IO () +main = do + args <- getArgs + let fontArg = listToMaybe [a | a <- args, not ("--" `isPrefixOf` a)] + fontPath <- resolveFont fontArg + + -- Create an IORef to store the controller once we get it + controllerRef <- newIORef Nothing + + let initialState = + AppState + { fontPath = fontPath + , mousePos = (0, 0) + , hoveredCursor = Nothing + } + + interactIO + (InWindow "Cursor Demo" (600, 500) (100, 100)) + (greyN 0.95) + initialState + (pure . renderScene) + (handleEvent controllerRef) + (writeIORef controllerRef . Just) + + +-- | Application state +data AppState + = AppState + { fontPath :: FilePath + , mousePos :: Point + , hoveredCursor :: Maybe CursorShape + } + + +-- | Button definition linking to a cursor shape +data CursorButton + = CursorButton + { cbShape :: CursorShape + , cbLabel :: T.Text + , cbDescription :: T.Text + , cbX :: Float + , cbY :: Float + , cbWidth :: Float + , cbHeight :: Float + } + + +-- | Define buttons for each cursor type +cursorButtons :: [CursorButton] +cursorButtons = + [ CursorButton CursorArrow "Arrow" "Default pointer" (-200) 80 180 60 + , CursorButton CursorHand "Hand" "Clickable items" (50) 80 180 60 + , CursorButton CursorIBeam "I-Beam" "Text selection" (-200) 0 180 60 + , CursorButton CursorCrosshair "Crosshair" "Precision select" (50) 0 180 60 + , CursorButton CursorResizeH "Resize H" "Horizontal resize" (-200) (-80) 180 60 + , CursorButton CursorResizeV "Resize V" "Vertical resize" (50) (-80) 180 60 + , CursorButton CursorHidden "Hidden" "No cursor" (-75) (-160) 180 60 + ] + + +-- | Check if a point is inside a button +pointInButton :: Point -> CursorButton -> Bool +pointInButton (x, y) btn = + let x1 = cbX btn + y1 = cbY btn + x2 = x1 + cbWidth btn + y2 = y1 + cbHeight btn + in x >= x1 && x <= x2 && y >= y1 && y <= y2 + + +-- | Find which cursor button (if any) is at the given point +findButtonAt :: Point -> [CursorButton] -> Maybe CursorButton +findButtonAt pt btns = + case filter (pointInButton pt) btns of + (btn : _) -> Just btn + [] -> Nothing + + +-- | Render the entire scene +renderScene :: AppState -> Picture +renderScene state = + Pictures + [ -- Header + Translate 0 200 $ renderHeader (fontPath state) + , -- Buttons + Pictures $ map (renderButton state) cursorButtons + , -- Status bar + Translate 0 (-200) $ renderStatusBar state + ] + + +-- | Render the header +renderHeader :: FilePath -> Picture +renderHeader font = + Pictures + [ Color (makeColor 0.2 0.5 0.7 1.0) $ rectangleSolid 600 60 + , Translate (-250) (-12) $ + Color white $ + TrueTypeText font 32 "Cursor Shape Demo" + ] + + +-- | Render a cursor button +renderButton :: AppState -> CursorButton -> Picture +renderButton state btn = + let isHovered = hoveredCursor state == Just (cbShape btn) + + bgColor + | isHovered = makeColor 0.3 0.6 0.9 1.0 + | otherwise = makeColor 0.6 0.6 0.6 1.0 + + textColor + | isHovered = white + | otherwise = greyN 0.95 + + cx = cbX btn + cbWidth btn / 2 + cy = cbY btn + cbHeight btn / 2 + in Translate cx cy $ + Pictures + [ -- Background + Color bgColor $ rectangleSolid (cbWidth btn) (cbHeight btn) + , -- Border + Color (greyN 0.3) $ rectangleWire (cbWidth btn) (cbHeight btn) + , -- Label + Translate (-80) 5 $ + Color textColor $ + TrueTypeText (fontPath state) 22 (cbLabel btn) + , -- Description + Translate (-80) (-18) $ + Color (if isHovered then greyN 0.9 else greyN 0.75) $ + TrueTypeText (fontPath state) 14 (cbDescription btn) + ] + + +-- | Render the status bar +renderStatusBar :: AppState -> Picture +renderStatusBar state = + let cursorText = case hoveredCursor state of + Nothing -> "Hover over a button to change cursor" + Just shape -> "Current cursor: " <> T.pack (show shape) + in Pictures + [ Color (greyN 0.85) $ rectangleSolid 600 50 + , Translate (-270) (-8) $ + Color (greyN 0.3) $ + TrueTypeText (fontPath state) 18 cursorText + ] + + +-- | Handle input events +handleEvent :: IORef (Maybe Controller) -> Event -> AppState -> IO AppState +handleEvent controllerRef event state = + case event of + EventMotion pos -> do + let mBtn = findButtonAt pos cursorButtons + newHovered = cbShape <$> mBtn + + -- Update cursor when hovering changes + mCtrl <- readIORef controllerRef + case (mCtrl, newHovered) of + (Just ctrl, Just shape) -> controllerSetCursor ctrl shape + (Just ctrl, Nothing) -> controllerSetCursor ctrl CursorArrow + _ -> pure () + + pure $ + state + { mousePos = pos + , hoveredCursor = newHovered + } + _ -> pure state + + +-- | Font resolution logic +resolveFont :: Maybe FilePath -> IO FilePath +resolveFont (Just fp) = ensureFont fp +resolveFont Nothing = do + found <- foldM pick Nothing candidateFonts + case found of + Just fp -> pure fp + Nothing -> do + hPutStrLn stderr $ + unlines + [ "brillo-cursors: unable to locate a TrueType font." + , "Tried the following paths:" + , unlines (map (" - " <>) candidateFonts) + , "Pass a font explicitly: stack run brillo-cursors -- /path/to/font.ttf" + ] + exitFailure + where + pick acc candidate = + case acc of + Just _ -> pure acc + Nothing -> do + exists <- doesFileExist candidate + pure $ if exists then Just candidate else Nothing + + +ensureFont :: FilePath -> IO FilePath +ensureFont fp = do + exists <- doesFileExist fp + if exists + then pure fp + else do + hPutStrLn stderr $ "brillo-cursors: font file not found: " <> fp + exitFailure + + +candidateFonts :: [FilePath] +candidateFonts = + [ "/System/Library/Fonts/Supplemental/Arial.ttf" + , "/Library/Fonts/Arial.ttf" + , "/System/Library/Fonts/Supplemental/Helvetica.ttc" + , "/System/Library/Fonts/Supplemental/Tahoma.ttf" + , "/usr/share/fonts/truetype/dejavu/DejaVuSans.ttf" + , "/usr/share/fonts/truetype/liberation/LiberationSans-Regular.ttf" + , "/usr/share/fonts/truetype/freefont/FreeSans.ttf" + , "C:\\Windows\\Fonts\\arial.ttf" + , "C:\\Windows\\Fonts\\segoeui.ttf" + ] diff --git a/picture/Draw/Main.hs b/picture/Draw/Main.hs --- a/picture/Draw/Main.hs +++ b/picture/Draw/Main.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {-| Simple picture drawing application. diff --git a/picture/DropFiles/Main.hs b/picture/DropFiles/Main.hs new file mode 100644 --- /dev/null +++ b/picture/DropFiles/Main.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Drag & drop files onto the window to load them +module Main where + +import Brillo +import Brillo.Interface.Pure.Game +import Data.Function ((&)) +import Data.Functor ((<&>)) +import Data.Text qualified as T + + +width :: (Num a) => a +width = 600 + + +height :: (Num a) => a +height = 600 + + +data State + = -- | Dropped files and directories + State [FilePath] + + +-- | Convert the state to a picture +makePicture :: State -> Picture +makePicture (State filePaths) = + Pictures $ + filePaths & zip [(1 :: Int) ..] <&> \(i, filePath) -> + Translate (-width / 2) (fromIntegral (-25 * i) + (height / 2)) $ + Scale 0.1 0.1 $ + Text $ + T.pack filePath + + +-- | Handle drag & drop events +handleEvent :: Event -> State -> State +handleEvent event state = + case event of + EventDrop filePaths -> State filePaths + _ -> state + + +stepWorld :: Float -> State -> State +stepWorld _ = id + + +main :: IO () +main = do + let state = State [] + play + (InWindow "DropFiles" (width, height) (0, 0)) + white + 100 + state + makePicture + handleEvent + stepWorld diff --git a/picture/Easy/Main.hs b/picture/Easy/Main.hs --- a/picture/Easy/Main.hs +++ b/picture/Easy/Main.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + module Main where import Brillo diff --git a/picture/Eden/Main.hs b/picture/Eden/Main.hs --- a/picture/Eden/Main.hs +++ b/picture/Eden/Main.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + -- Adapted from ANUPlot version by Clem Baker-Finch module Main where diff --git a/picture/Eden/World.hs b/picture/Eden/World.hs --- a/picture/Eden/World.hs +++ b/picture/Eden/World.hs @@ -34,7 +34,7 @@ -- Consume some random numbers to advance the simulation evolve :: ViewPort -> Float -> World -> World -evolve vp step world@(World comm gen steps) +evolve _vp _step world@(World comm gen steps) | steps < maxSteps = let (genThis, genNext) = split gen (genA, genS) = split genThis @@ -47,6 +47,6 @@ -- Converting the world to a picture is just converting the community component render :: World -> Picture -render (World comm gen steps) = +render (World comm _gen _steps) = Color (makeColor 0.3 0.3 0.6 1.0) $ Community.render comm diff --git a/picture/Export/Main.hs b/picture/Export/Main.hs new file mode 100644 --- /dev/null +++ b/picture/Export/Main.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE OverloadedStrings #-} + +{-| Example demonstrating how to export Brillo pictures to various image formats + using the brillo-export library. + + This example creates several geometric shapes and exports them as: + - PNG files + - BMP files + - TGA files + - TIFF files + - An animated GIF +-} +module Main where + +import Brillo +import Brillo.Export +import System.Directory (createDirectoryIfMissing) + + +-- | A simple picture with colored shapes +samplePicture :: Picture +samplePicture = + Pictures + [ Color red $ Translate (-50) 50 $ Circle 30 + , Color green $ Translate 50 50 $ rectangleSolid 60 60 + , Color blue $ Translate 0 (-50) $ Polygon [(-30, 0), (30, 0), (0, 50)] + , Color orange $ Text "Brillo" + ] + + +-- | A fractal tree for more complex visualization +tree :: Float -> Float -> Picture +tree width depth + | depth < 1 = Blank + | otherwise = + Pictures + [ Line [(0, 0), (0, width)] + , Translate 0 width $ Rotate 30 $ tree (width * 0.7) (depth - 1) + , Translate 0 width $ Rotate (-30) $ tree (width * 0.7) (depth - 1) + ] + + +-- | Generate an animation frame +animationFrame :: Float -> Picture +animationFrame t = + Pictures + [ Color (makeColor r g b 1.0) $ Rotate (t * 10) $ rectangleSolid size size + , Color (makeColor g b r 1.0) $ Rotate (-t * 15) $ Circle (size / 2) + ] + where + size = 100 + 50 * sin (t / 10) + r = (sin t + 1) / 2 + g = (sin (t + 2) + 1) / 2 + b = (sin (t + 4) + 1) / 2 + + +main :: IO () +main = do + putStrLn "Exporting Brillo pictures to various formats..." + + -- Create output directory if it doesn't exist + createDirectoryIfMissing True "output" + + -- Export simple picture to PNG + putStrLn "Exporting to PNG..." + exportPictureToPNG (400, 400) white "output/sample.png" samplePicture + + -- Export to BMP + putStrLn "Exporting to BMP..." + exportPictureToBitmap (400, 400) white "output/sample.bmp" samplePicture + + -- Export to TGA + putStrLn "Exporting to TGA..." + exportPictureToTga (400, 400) white "output/sample.tga" samplePicture + + -- Export to TIFF + putStrLn "Exporting to TIFF..." + exportPictureToTiff (400, 400) white "output/sample.tiff" samplePicture + + -- Export tree to PNG with different background + putStrLn "Exporting tree to PNG..." + exportPictureToPNG (500, 500) (greyN 0.1) "output/tree.png" $ + Color green $ + tree 80 8 + + -- Export multiple pictures as animated GIF + putStrLn "Exporting animated GIF..." + let frames = [0, 5 .. 355] -- 72 frames + delay = 5 -- 50ms delay between frames (20 fps) + exportPicturesToGif + delay + LoopingForever + (400, 400) + white + "output/animation.gif" + animationFrame + frames + + putStrLn "\nExport complete:" + putStrLn "- output/sample.png (PNG format)" + putStrLn "- output/sample.bmp (Bitmap format)" + putStrLn "- output/sample.tga (TGA format)" + putStrLn "- output/sample.tiff (TIFF format)" + putStrLn "- output/tree.png (Fractal tree)" + putStrLn "- output/animation.gif (Animated GIF)" diff --git a/picture/Flake/Main.hs b/picture/Flake/Main.hs --- a/picture/Flake/Main.hs +++ b/picture/Flake/Main.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + {-| Snowflake Fractal. Based on ANUPlot code by Clem Baker-Finch. -} diff --git a/picture/FuleLayout/Main.hs b/picture/FuleLayout/Main.hs new file mode 100644 --- /dev/null +++ b/picture/FuleLayout/Main.hs @@ -0,0 +1,279 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{-| FULE Layout Engine Demo + +This example demonstrates the key features of FULE (Functional UI Layout Engine): + +1. **Grid layouts** - Evenly spaced 2D grids of items +2. **Layered containers** - Overlapping elements in the same bounds +3. **Padded containers** - Content with configurable margins +4. **Sized containers** - Fixed-size elements +5. **Positioned containers** - Place content at corners, edges, or center +6. **Dynamic resizing** - Layouts that respond to window size changes +6. **Flat data structures** - Easy-to-traverse component info + +The demo shows a dashboard-style layout with: +- A grid of colored panels +- A status indicator overlay +-} +module Main where + +import Brillo +import Brillo.Interface.Pure.Game +import Data.Functor.Identity (Identity) +import Data.List (find) +import Data.Text qualified as T +import FULE + + +-- | Widget types for our UI +data Widget + = -- | Controls window resize, storing guide IDs for dynamic layout updates + WindowResize + { widgetWidthGuide :: GuideID + , widgetHeightGuide :: GuideID + } + | -- | A colored panel with a label + Panel + { panelLabel :: T.Text + , panelColor :: Color + } + | -- | Overlay indicator (layered on top) + StatusIndicator T.Text + + +-- | Application state +data AppState = AppState + { stateLayout :: Layout + , stateComponents :: [ComponentInfo Widget] + , stateWindowSize :: (Int, Int) + , stateHoveredPanel :: Maybe T.Text + , stateSelectedPanel :: Maybe T.Text + } + + +-- | Initial window dimensions +initialWidth, initialHeight :: Int +initialWidth = 800 +initialHeight = 600 + + +-- | Build the complete layout demonstrating FULE's features +buildLayout :: Int -> Int -> (Layout, [ComponentInfo Widget]) +buildLayout width height = + layout + ( window + (width, height) + WindowResize -- WindowAdjustorGen creates the resize controller + mainContainer + ) + where + -- Feature: Layered container for overlapping elements + -- This lets us place a status indicator on top of the main grid + mainContainer :: Layered Widget + mainContainer = + layered + ( [ item contentGrid + , item statusOverlay + ] :: + [Item Widget] + ) + + -- Feature: Padded container wraps the grid with margins + -- Feature: Grid layout for evenly-spaced content panels + contentGrid :: Padded (Grid Widget) + contentGrid = + padded + (padding 20 20) -- horizontal, vertical padding + -- Feature: 2D Grid layout - items fill from top-left, row by row + ( grid + (3, 3) -- 3 columns, 3 rows + ( [ item (Panel "Analytics" (makeColorI 66 133 244 255)) -- Blue + , item (Panel "Users" (makeColorI 52 168 83 255)) -- Green + , item (Panel "Revenue" (makeColorI 251 188 5 255)) -- Yellow + , item (Panel "Traffic" (makeColorI 234 67 53 255)) -- Red + , item (Panel "Events" (makeColorI 155 89 182 255)) -- Purple + , item (Panel "Reports" (makeColorI 26 188 156 255)) -- Teal + , item (Panel "Settings" (makeColorI 241 196 15 255)) -- Gold + , item (Panel "Logs" (makeColorI 52 73 94 255)) -- Dark blue-grey + , item (Panel "Help" (makeColorI 149 165 166 255)) -- Grey + ] :: + [Item Widget] + ) + ) + + -- Feature: Positioned + Sized containers + -- Positioned places content at one of 9 positions (corners, edges, center) + -- Sized gives it fixed dimensions + statusOverlay :: Positioned (Padded (Sized (ItemM Identity Widget))) + statusOverlay = + topRight $ -- Position in top-right corner + padded (padding 10 10) $ -- Add some margin from the edge + sized + (80, 25) + (item (StatusIndicator "Live")) + + +-- | Create initial application state +initialState :: AppState +initialState = + let (ly, comps) = buildLayout initialWidth initialHeight + in AppState + { stateLayout = ly + , stateComponents = comps + , stateWindowSize = (initialWidth, initialHeight) + , stateHoveredPanel = Nothing + , stateSelectedPanel = Nothing + } + + +-- | Convert layout to Brillo Picture +renderState :: AppState -> Picture +renderState state = + Pictures $ map renderComponent (stateComponents state) + where + hovered = stateHoveredPanel state + selected = stateSelectedPanel state + + renderComponent :: ComponentInfo Widget -> Picture + renderComponent compInfo = + case componentOf compInfo of + WindowResize{} -> Blank -- Invisible resize controller + Panel label col -> + let bounds = boundsOf compInfo + (x, y, w, h) = boundsToRect bounds + isHovered = hovered == Just label + isSelected = selected == Just label + bgColor + | isSelected = brighten (brighten col) + | isHovered = brighten col + | otherwise = col + borderColor + | isSelected = white + | otherwise = greyN 0.2 + in translateToCenter x y w h $ + Pictures $ + [Color bgColor $ rectangleSolid w h] + ++ if isSelected + then [Color borderColor $ rectangleWire (w - 4) (h - 4)] + else [Color borderColor $ rectangleWire w h] + StatusIndicator _ -> + let bounds = boundsOf compInfo + (x, y, w, h) = boundsToRect bounds + in translateToCenter x y w h $ + Pictures + [ Color (makeColorI 52 168 83 220) $ rectangleSolid w h + , Color (greyN 0.1) $ rectangleWire w h + ] + + -- Convert FULE bounds to rectangle dimensions + boundsToRect :: Bounds -> (Float, Float, Float, Float) + boundsToRect bounds = + let ly = stateLayout state + top = fromIntegral $ getGuide (topOf bounds) ly + left = fromIntegral $ getGuide (leftOf bounds) ly + right = fromIntegral $ getGuide (rightOf bounds) ly + bottom = fromIntegral $ getGuide (bottomOf bounds) ly + w = right - left + h = bottom - top + -- FULE uses top-left origin, Brillo uses center origin + (winW, winH) = stateWindowSize state + x = left + w / 2 - fromIntegral winW / 2 + y = fromIntegral winH / 2 - top - h / 2 + in (x, y, w, h) + + translateToCenter :: Float -> Float -> Float -> Float -> Picture -> Picture + translateToCenter x y _ _ = Translate x y + + brighten :: Color -> Color + brighten c = + let (r, g, b, a) = rgbaOfColor c + in makeColor (min 1 (r + 0.15)) (min 1 (g + 0.15)) (min 1 (b + 0.15)) a + + +-- | Handle events +handleEvent :: Event -> AppState -> AppState +handleEvent event state = + case event of + -- Feature: Dynamic window resizing + -- FULE layouts respond to window size changes automatically + EventResize (newW, newH) -> + let (ly, comps) = buildLayout newW newH + in state + { stateLayout = ly + , stateComponents = comps + , stateWindowSize = (newW, newH) + } + -- Handle mouse clicks on panels + EventKey (MouseButton LeftButton) Down _ pos -> + state{stateSelectedPanel = findClickedPanel pos state} + -- Handle mouse movement for hover effects + EventMotion pos -> + state{stateHoveredPanel = findHoveredPanel pos state} + _ -> state + + +-- | Find which panel was clicked +findClickedPanel :: Point -> AppState -> Maybe T.Text +findClickedPanel (mx, my) state = + case find isPanelClicked (stateComponents state) of + Just compInfo -> + case componentOf compInfo of + Panel label _ -> Just label + _ -> Nothing + Nothing -> Nothing + where + isPanelClicked compInfo = + case componentOf compInfo of + Panel{} -> pointInBounds (mx, my) (boundsOf compInfo) state + _ -> False + + +-- | Find which panel the mouse is hovering over +findHoveredPanel :: Point -> AppState -> Maybe T.Text +findHoveredPanel (mx, my) state = + case find isPanelHovered (stateComponents state) of + Just compInfo -> + case componentOf compInfo of + Panel label _ -> Just label + _ -> Nothing + Nothing -> Nothing + where + isPanelHovered compInfo = + case componentOf compInfo of + Panel{} -> pointInBounds (mx, my) (boundsOf compInfo) state + _ -> False + + +-- | Check if a point is within bounds +pointInBounds :: Point -> Bounds -> AppState -> Bool +pointInBounds (mx, my) bounds state = + let ly = stateLayout state + top = fromIntegral $ getGuide (topOf bounds) ly + left = fromIntegral $ getGuide (leftOf bounds) ly + right = fromIntegral $ getGuide (rightOf bounds) ly + bottom = fromIntegral $ getGuide (bottomOf bounds) ly + (winW, winH) = stateWindowSize state + -- Convert Brillo coords (center origin) to FULE coords (top-left origin) + fulex = mx + fromIntegral winW / 2 + fuley = fromIntegral winH / 2 - my + in fulex >= left && fulex <= right && fuley >= top && fuley <= bottom + + +-- | Step function (no animation needed) +stepWorld :: Float -> AppState -> AppState +stepWorld _ = id + + +-- | Main entry point +main :: IO () +main = + play + (InWindow "FULE Layout Demo" (initialWidth, initialHeight) (100, 100)) + (greyN 0.1) -- Dark background + 60 -- FPS + initialState + renderState + handleEvent + stepWorld diff --git a/picture/GUI/Main.hs b/picture/GUI/Main.hs new file mode 100644 --- /dev/null +++ b/picture/GUI/Main.hs @@ -0,0 +1,274 @@ +{-# LANGUAGE OverloadedStrings #-} + +{-| Simple GUI demo with layout and buttons using TrueType fonts. + Demonstrates a high-level layout system with interactive buttons. +-} +module Main where + +import Brillo +import Brillo.Interface.Pure.Game +import Control.Monad (foldM) +import Data.List (isPrefixOf) +import Data.Maybe (listToMaybe) +import Data.Text qualified as T +import System.Directory (doesFileExist) +import System.Environment (getArgs) +import System.Exit (exitFailure) +import System.IO (hPutStrLn, stderr) + + +main :: IO () +main = do + args <- getArgs + let fontArg = listToMaybe [a | a <- args, not ("--" `isPrefixOf` a)] + fontPath <- resolveFont fontArg + + let initialState = + AppState + { fontPath = fontPath + , mousePos = (0, 0) + , lastClicked = Nothing + , hoveredButton = Nothing + } + + play + (InWindow "Brillo GUI Demo" (800, 600) (100, 100)) + (greyN 0.95) + 60 + initialState + renderScene + handleEvent + stepWorld + + +-- | Application state +data AppState + = AppState + { fontPath :: FilePath + , mousePos :: Point + , lastClicked :: Maybe String + , hoveredButton :: Maybe String + } + + +-- | Button definition +data Button + = Button + { buttonId :: String + , buttonLabel :: T.Text + , buttonX :: Float + , buttonY :: Float + , buttonWidth :: Float + , buttonHeight :: Float + } + + +-- | Define our buttons +buttons :: [Button] +buttons = + [ Button "new" "New" (-300) (-220) 140 50 + , Button "open" "Open" (-140) (-220) 140 50 + , Button "save" "Save" 20 (-220) 140 50 + , Button "close" "Close" 180 (-220) 140 50 + ] + + +-- | Check if a point is inside a button +pointInButton :: Point -> Button -> Bool +pointInButton (x, y) btn = + let x1 = buttonX btn + y1 = buttonY btn + x2 = x1 + buttonWidth btn + y2 = y1 + buttonHeight btn + in x >= x1 && x <= x2 && y >= y1 && y <= y2 + + +-- | Find which button (if any) is at the given point +findButtonAt :: Point -> [Button] -> Maybe String +findButtonAt pt btns = + case filter (pointInButton pt) btns of + (btn : _) -> Just (buttonId btn) + [] -> Nothing + + +-- | Render the entire scene +renderScene :: AppState -> Picture +renderScene state = + Pictures + [ -- Header section + Translate 0 220 $ renderHeader (fontPath state) + , -- Main content area + Translate 0 50 $ renderContent (fontPath state) (lastClicked state) + , -- Button bar at bottom + Pictures $ map (renderButton state) buttons + , -- Status bar + Translate 0 (-280) $ renderStatusBar (fontPath state) (mousePos state) + ] + + +-- | Render the header with title +renderHeader :: FilePath -> Picture +renderHeader font = + Pictures + [ -- Header background + Color (makeColor 0.2 0.4 0.7 1.0) $ rectangleSolid 800 80 + , -- Title text + Translate (-350) (-10) $ + Color white $ + TrueTypeText font 42 "Brillo GUI Demo" + ] + + +-- | Render the main content area +renderContent :: FilePath -> Maybe String -> Picture +renderContent font mLastClicked = + Pictures + [ -- Content background + Color (makeColor 0.98 0.98 1.0 1.0) $ rectangleSolid 760 300 + , -- Border + Color (greyN 0.7) $ rectangleWire 760 300 + , -- Display last clicked button + case mLastClicked of + Nothing -> + Translate (-250) 40 $ + Color (greyN 0.5) $ + TrueTypeText font 32 "Click a button below!" + Just btnId -> + Pictures + [ Translate (-300) 60 $ + Color (makeColor 0.2 0.6 0.3 1.0) $ + TrueTypeText font 32 "Button clicked:" + , Translate (-300) 0 $ + Color (makeColor 0.3 0.3 0.8 1.0) $ + TrueTypeText font 48 (T.pack btnId) + , Translate (-300) (-70) $ + Color (greyN 0.4) $ + TrueTypeText font 24 "Try clicking other buttons!" + ] + ] + + +-- | Render a single button +renderButton :: AppState -> Button -> Picture +renderButton state btn = + let isHovered = hoveredButton state == Just (buttonId btn) + isClicked = lastClicked state == Just (buttonId btn) + + -- Choose colors based on state + bgColor + | isClicked = makeColor 0.2 0.7 0.3 1.0 + | isHovered = makeColor 0.4 0.6 0.9 1.0 + | otherwise = makeColor 0.5 0.5 0.5 1.0 + + textColor + | isClicked || isHovered = white + | otherwise = greyN 0.95 + + -- Calculate center position for the button + cx = buttonX btn + buttonWidth btn / 2 + cy = buttonY btn + buttonHeight btn / 2 + + -- Text positioning (centered in button) + textOffset = -12 -- Approximate vertical centering for text + in Translate cx cy $ + Pictures + [ -- Button background + Color bgColor $ + rectangleSolid (buttonWidth btn) (buttonHeight btn) + , -- Button border + Color (greyN 0.2) $ + rectangleWire (buttonWidth btn) (buttonHeight btn) + , -- Button label + Translate (-50) textOffset $ + Color textColor $ + TrueTypeText (fontPath state) 28 (buttonLabel btn) + ] + + +-- | Render the status bar showing mouse position +renderStatusBar :: FilePath -> Point -> Picture +renderStatusBar font (mx, my) = + Pictures + [ Color (greyN 0.85) $ rectangleSolid 800 40 + , Translate (-380) (-8) $ + Color (greyN 0.3) $ + TrueTypeText + font + 18 + ( T.pack $ + "Mouse: (" ++ show (round mx :: Int) ++ ", " ++ show (round my :: Int) ++ ")" + ) + ] + + +-- | Handle input events +handleEvent :: Event -> AppState -> AppState +handleEvent event state = + case event of + -- Track mouse position + EventMotion pos -> + state + { mousePos = pos + , hoveredButton = findButtonAt pos buttons + } + -- Handle mouse clicks on buttons + EventKey (MouseButton LeftButton) Down _ pos -> + case findButtonAt pos buttons of + Just btnId -> state{lastClicked = Just btnId} + Nothing -> state + -- Other events + _ -> state + + +-- | Update function (not used in this static demo) +stepWorld :: Float -> AppState -> AppState +stepWorld _ = id + + +-- | Font resolution logic +resolveFont :: Maybe FilePath -> IO FilePath +resolveFont (Just fp) = ensureFont fp +resolveFont Nothing = do + found <- foldM pick Nothing candidateFonts + case found of + Just fp -> pure fp + Nothing -> do + hPutStrLn stderr $ + unlines + [ "brillo-gui: unable to locate a TrueType font." + , "Tried the following paths:" + , unlines (map (" • " <>) candidateFonts) + , "Pass a font explicitly: stack run brillo-gui -- /path/to/font.ttf" + ] + exitFailure + where + pick acc candidate = + case acc of + Just _ -> pure acc + Nothing -> do + exists <- doesFileExist candidate + pure $ if exists then Just candidate else Nothing + + +ensureFont :: FilePath -> IO FilePath +ensureFont fp = do + exists <- doesFileExist fp + if exists + then pure fp + else do + hPutStrLn stderr $ "brillo-gui: font file not found: " <> fp + exitFailure + + +candidateFonts :: [FilePath] +candidateFonts = + [ "/System/Library/Fonts/Supplemental/Arial.ttf" + , "/Library/Fonts/Arial.ttf" + , "/System/Library/Fonts/Supplemental/Helvetica.ttc" + , "/System/Library/Fonts/Supplemental/Tahoma.ttf" + , "/usr/share/fonts/truetype/dejavu/DejaVuSans.ttf" + , "/usr/share/fonts/truetype/liberation/LiberationSans-Regular.ttf" + , "/usr/share/fonts/truetype/freefont/FreeSans.ttf" + , "C:\\Windows\\Fonts\\arial.ttf" + , "C:\\Windows\\Fonts\\segoeui.ttf" + ] diff --git a/picture/GameEvent/Main.hs b/picture/GameEvent/Main.hs --- a/picture/GameEvent/Main.hs +++ b/picture/GameEvent/Main.hs @@ -1,6 +1,9 @@ +{-# LANGUAGE OverloadedStrings #-} + module Main where import Brillo +import Data.Text qualified as T -- | Display the last event received as text. @@ -12,5 +15,5 @@ 100 "" (\str -> Translate (-340) 0 $ Scale 0.1 0.1 $ Text str) - (\event _ -> show event) + (\event _ -> T.pack $ show event) (\_ world -> world) diff --git a/picture/Graph/Main.hs b/picture/Graph/Main.hs --- a/picture/Graph/Main.hs +++ b/picture/Graph/Main.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + -- See for a lengthy -- explanation about this code. import Data.Map.Strict (Map) @@ -163,10 +165,10 @@ charge = 100000 -pushForce - :: Point -- Vertex we're calculating the force for - -> Point -- Vertex pushing the other away - -> Vector +pushForce :: + Point -> -- Vertex we're calculating the force for + Point -> -- Vertex pushing the other away + Vector pushForce v1 v2 = -- If we are analysing the same vertex, l = 0 if l > 0 @@ -187,11 +189,11 @@ -- | Apply forces to update the position of a single point. -updatePosition - :: Float -- Time since the last update - -> Vertex -- Vertex we are analysing - -> Scene - -> Point -- New position +updatePosition :: + Float -> -- Time since the last update + Vertex -> -- Vertex we are analysing + Scene -> + Point -- New position updatePosition dt v1 sc@Scene{scPoints = pts, scGraph = gr} = v1pos Pt.+ pull Pt.+ push where @@ -225,11 +227,11 @@ -- | Check if a point is in the given circle. -inCircle - :: Point -- Where the user has clicked - -> Float -- The scaling factor in the ViewPort - -> Point -- The position of the vertex - -> Bool +inCircle :: + Point -> -- Where the user has clicked + Float -> -- The scaling factor in the ViewPort + Point -> -- The position of the vertex + Bool inCircle p sca v = magV (v Pt.- p) <= vertexRadius * sca diff --git a/picture/Gravity/Main.hs b/picture/Gravity/Main.hs --- a/picture/Gravity/Main.hs +++ b/picture/Gravity/Main.hs @@ -21,7 +21,7 @@ window = FullScreen background = black fps = 60 - render xs = pictures $ map particleImage xs + render xs = Pictures $ map particleImage xs update _ = updateParticles @@ -48,7 +48,7 @@ -- | Particle to its picture particleImage :: Particle -> Picture particleImage (x, y, _, _) = - translate x y $ color white $ circleSolid 2 + Translate x y $ Color white $ circleSolid 2 -- | To update particles for next frame diff --git a/picture/Hello/Main.hs b/picture/Hello/Main.hs --- a/picture/Hello/Main.hs +++ b/picture/Hello/Main.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + -- | Display "Hello World" in a window. module Main where diff --git a/picture/Interaction/Main.hs b/picture/Interaction/Main.hs new file mode 100644 --- /dev/null +++ b/picture/Interaction/Main.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Brillo +import Brillo.Interface.IO.Interact +import Data.Text qualified as T + + +handleEvent :: Event -> Int -> IO Int +handleEvent e eventIdx = + case e of + EventKey _ Down _ _ -> do + putStrLn $ unwords ["--- Event", show eventIdx, "---"] + print e + return $ eventIdx + 1 + _ -> return eventIdx + + +-- | Count the events as they are received. +main :: IO () +main = + interactIO + (InWindow "GameEvent" (700, 100) (10, 10)) + white + 0 + (\str -> return $ Translate (-340) 0 $ Scale 0.3 0.3 $ Text $ T.pack $ show str) + handleEvent + (const $ return ()) diff --git a/picture/Lifespan/Community.hs b/picture/Lifespan/Community.hs --- a/picture/Lifespan/Community.hs +++ b/picture/Lifespan/Community.hs @@ -22,10 +22,10 @@ zipWith4 :: (a -> b -> c -> d -> e) -> [a] -> [b] -> [c] -> [d] -> [e] -zipWith4 f [] _ _ _ = [] -zipWith4 f _ [] _ _ = [] -zipWith4 f _ _ [] _ = [] -zipWith4 f _ _ _ [] = [] +zipWith4 _f [] _ _ _ = [] +zipWith4 _f _ [] _ _ = [] +zipWith4 _f _ _ [] _ = [] +zipWith4 _f _ _ _ [] = [] zipWith4 f (b : bs) (c : cs) (d : ds) (e : es) = f b c d e : zipWith4 f bs cs ds es @@ -43,7 +43,7 @@ age :: Community -> Community age [] = [] -age (Cell c r 0 : cells) = age cells +age (Cell _c _r 0 : cells) = age cells age (Cell c r life : cells) = Cell c r (life - 1) : age cells diff --git a/picture/Lifespan/Main.hs b/picture/Lifespan/Main.hs --- a/picture/Lifespan/Main.hs +++ b/picture/Lifespan/Main.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + -- Adapted from ANUPlot version by Clem Baker-Finch module Main where diff --git a/picture/Lifespan/World.hs b/picture/Lifespan/World.hs --- a/picture/Lifespan/World.hs +++ b/picture/Lifespan/World.hs @@ -47,6 +47,6 @@ -- Converting the world to a picture is just converting the community component render :: World -> Picture -render (World comm gen _) = +render (World comm _gen _) = Color (makeColor 0.3 0.3 0.6 1.0) $ Community.render comm diff --git a/picture/Lines/Main.hs b/picture/Lines/Main.hs new file mode 100644 --- /dev/null +++ b/picture/Lines/Main.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Brillo ( + Display (InWindow), + Picture (Line, LineAliased, Pictures, ThickLine, ThickLineAliased, Translate), + play, + white, + ) +import Brillo.Interface.Pure.Game (Event) + + +main :: IO () +main = + do + let state = State [] + play + (InWindow "Lines" (600, 600) (0, 0)) + white + 100 + state + makePicture + handleEvent + stepWorld + + +newtype State = State [Picture] + + +exampleLines :: [Picture] +exampleLines = + [ Line [(0, 0), (50, 200)] + , LineAliased [(20, 0), (70, 200)] + , ThickLine [(50, 0), (100, 200)] 1 + , ThickLineAliased [(70, 0), (120, 200)] 1 + , ThickLine [(100, 0), (150, 200)] 2 + , ThickLineAliased [(120, 0), (170, 200)] 2 + , ThickLine [(150, 0), (200, 200)] 3 + , ThickLineAliased [(170, 0), (220, 200)] 3 + , ThickLine [(200, 0), (250, 200)] 5 + , ThickLineAliased [(220, 0), (270, 200)] 5 + , ThickLine [(250, 0), (300, 200)] 8 + , ThickLineAliased [(270, 0), (320, 200)] 8 + , ThickLine [(300, 0), (350, 200)] 13 + , ThickLineAliased [(320, 0), (370, 200)] 13 + , ThickLine [(350, 0), (400, 200)] 16 + , ThickLineAliased [(370, 0), (420, 200)] 16 + , -- Thickness is reset to 1 after each line + Line [(400, 0), (450, 200)] + -- -- | This would print an error and look like the previous line, + -- -- | as the max supported thickness is 16 on macOS. + -- ThickLine [(450, 0), (500, 200)] 20 + -- , ThickLineAliased [(470, 0), (520, 200)] 20 + ] + + +-- | Convert our state to a picture. +makePicture :: State -> Picture +makePicture _state = + Translate (-220) (-80) $ Pictures exampleLines + + +handleEvent :: Event -> State -> State +handleEvent _event state = state + + +stepWorld :: Float -> State -> State +stepWorld _ = id diff --git a/picture/Machina/Main.hs b/picture/Machina/Main.hs --- a/picture/Machina/Main.hs +++ b/picture/Machina/Main.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + module Main where import Brillo diff --git a/picture/Occlusion/Cell.hs b/picture/Occlusion/Cell.hs --- a/picture/Occlusion/Cell.hs +++ b/picture/Occlusion/Cell.hs @@ -28,7 +28,7 @@ -- | The basic shape of a cell. cellShape :: Int -> Int -> Int -> Picture -cellShape cellSize posXi posYi = +cellShape _cellSize posXi posYi = let posX = fromIntegral posXi posY = fromIntegral posYi x1 = posX diff --git a/picture/Occlusion/Main.hs b/picture/Occlusion/Main.hs --- a/picture/Occlusion/Main.hs +++ b/picture/Occlusion/Main.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} import Brillo.Data.Extent @@ -70,7 +71,7 @@ picCellsVisible = Pictures $ map (uncurry (drawCell True world)) cellsVisible -- How big to draw the cells. - scale = fromIntegral $ worldCellSize world + scaleFactor = fromIntegral $ worldCellSize world (windowSizeX, windowSizeY) = windowSizeOfWorld $ @@ -80,14 +81,14 @@ offsetX = -(fromIntegral $ windowSizeX `div` 2) offsetY = -(fromIntegral $ windowSizeY `div` 2) in Translate offsetX offsetY $ - Scale scale scale $ + Scale scaleFactor scaleFactor $ Pictures [picCellsAll, picCellsVisible, picCellsHit, picRay] -- | Draw the cell hit by the ray defined by the user. drawHitCell :: World -> (Point, Extent, Cell) -> Picture -drawHitCell world (pos@(px, py), extent, cell) = - let (n, s, e, w) = takeExtent extent +drawHitCell _ (_, extent, _) = + let (_, s, _, w) = takeExtent extent x = w y = s @@ -98,7 +99,7 @@ -- | Draw the ray defined by the user. drawRay :: World -> Point -> Point -> Picture -drawRay world p1@(x, y) p2 = +drawRay _ p1@(x, y) p2 = Pictures [ Color red $ Line [p1, p2] , Color cyan $ diff --git a/picture/Occlusion/World.hs b/picture/Occlusion/World.hs --- a/picture/Occlusion/World.hs +++ b/picture/Occlusion/World.hs @@ -38,31 +38,32 @@ -- | Read a world from a string. readWorld :: String -> World readWorld str = - let ("WORLD" : strWidthHeight : skip : cellLines) = - lines str - - [width, height] = map read $ words strWidthHeight - rows = take height $ cellLines - - cells = - concat $ - map (readLine width) $ - reverse rows - - extent = makeExtent height 0 width 0 - in World - { worldWidth = width - , worldHeight = height - , worldTree = makeWorldTree extent cells - , worldCellSize = 20 - , worldCellSpace = 0 - } + case lines str of + ("WORLD" : strWidthHeight : _ : cellLines) -> + case map read $ words strWidthHeight of + [width, height] -> + let rows = take height cellLines + cells = + concat $ + map (readLine width) $ + reverse rows + extent = makeExtent height 0 width 0 + in World + { worldWidth = width + , worldHeight = height + , worldTree = makeWorldTree extent cells + , worldCellSize = 20 + , worldCellSpace = 0 + } + _ -> error "readWorld: invalid width/height format" + _ -> error "readWorld: invalid world format" readLine :: Int -> String -> [Cell] -readLine width (s : str) = +readLine width (_ : str) = map readCell $ take width str +readLine _ [] = [] -- | Get the size of the window needed to display a world. @@ -79,7 +80,7 @@ -- | Create the tree representing the world from a list of all its cells. makeWorldTree :: Extent -> [Cell] -> QuadTree Cell makeWorldTree extent cells = - foldr insert' emptyTree nonEmptyPosCells + foldr insert' TNil nonEmptyPosCells where insert' (pos, cell) tree = case insertByCoord extent pos cell tree of @@ -110,10 +111,10 @@ offsetX = fromIntegral $ windowSizeX `div` 2 offsetY = fromIntegral $ windowSizeY `div` 2 - scale = fromIntegral $ worldCellSize world + scaleFactor = fromIntegral $ worldCellSize world - x' = (x + offsetX) / scale - y' = (y + offsetY) / scale + x' = (x + offsetX) / scaleFactor + y' = (y + offsetY) / scaleFactor in (x', y') @@ -146,7 +147,7 @@ let mOccluder = castSegIntoWorld world p1 p2 in case mOccluder of Nothing -> False - Just (pos, extent, cell) -> pointInExtent extent p2 + Just (_, extent, _) -> pointInExtent extent p2 -- | Given a line segment (P1-P2) get the cell closest to P1 that intersects the segment. diff --git a/picture/PacMan/GhostAI.hs b/picture/PacMan/GhostAI.hs new file mode 100644 --- /dev/null +++ b/picture/PacMan/GhostAI.hs @@ -0,0 +1,1899 @@ +{-# LANGUAGE OverloadedRecordDot #-} + +module GhostAI where + +import Brillo +import Maze +import Structs + + +-- Round a Float to the nearest integer, returning Float +roundF :: Float -> Float +roundF x = fromIntegral (round x :: Int) + + +listLength :: [a] -> Int +listLength [] = 0 +listLength (_ : xs) = 1 + listLength xs + + +checkInList :: (Eq a) => a -> [a] -> Bool +checkInList x l + | x `elem` l = False + | otherwise = True + + +-- Scatter for 7 seconds, then Chase for 20 seconds. +-- Scatter for 7 seconds, then Chase for 20 seconds. +-- Scatter for 5 seconds, then Chase for 20 seconds. +-- Scatter for 5 seconds, then switch to Chase mode permanently. +-- add 3 seconds to everything because we stop the first 3 seconds +-- of the game for the start screen +ghostModeTimer :: PacGame -> PacGame +ghostModeTimer game + | curTime < 10 = + game + { gMode = SCATTER + , blinky = setGhost game.blinky blinkyScatterTarget + , pinky = setGhost game.pinky pinkyScatterTarget + , inky = setGhost game.inky inkyScatterTarget + , clyde = setGhost game.clyde clydeScatterTarget + } + | curTime >= 10 && curTime < 30 = + game + { gMode = CHASE + , blinky = setGhost game.blinky (x', y') + , pinky = setGhost game.pinky (x' + 3, y' + 3) + , inky = setGhost game.inky targetI + , clyde = setGhost game.clyde targetC + } + | curTime >= 30 && curTime < 37 = + game + { gMode = SCATTER + , blinky = setGhost game.blinky blinkyScatterTarget + , pinky = setGhost game.pinky pinkyScatterTarget + , inky = setGhost game.inky inkyScatterTarget + , clyde = setGhost game.clyde clydeScatterTarget + } + | curTime >= 37 && curTime < 57 = + game + { gMode = CHASE + , blinky = setGhost game.blinky (x', y') + , pinky = setGhost game.pinky (x' + 3, y' + 3) + , inky = setGhost game.inky targetI + , clyde = setGhost game.clyde targetC + } + | curTime >= 57 && curTime < 62 = + game + { gMode = SCATTER + , blinky = setGhost game.blinky blinkyScatterTarget + , pinky = setGhost game.pinky pinkyScatterTarget + , inky = setGhost game.inky inkyScatterTarget + , clyde = setGhost game.clyde clydeScatterTarget + } + | curTime >= 62 && curTime < 82 = + game + { gMode = CHASE + , blinky = setGhost game.blinky (x', y') + , pinky = setGhost game.pinky (x' + 3, y' + 3) + , inky = setGhost game.inky targetI + , clyde = setGhost game.clyde targetC + } + | curTime >= 82 && curTime < 87 = + game + { gMode = SCATTER + , blinky = setGhost game.blinky blinkyScatterTarget + , pinky = setGhost game.pinky pinkyScatterTarget + , inky = setGhost game.inky inkyScatterTarget + , clyde = setGhost game.clyde clydeScatterTarget + } + | curTime >= 87 && curTime < 107 = + game + { gMode = CHASE + , blinky = setGhost game.blinky (x', y') + , pinky = setGhost game.pinky (x' + 3, y' + 3) + , inky = setGhost game.inky targetI + , clyde = setGhost game.clyde targetC + } + | curTime >= 107 && curTime < 112 = + game + { gMode = SCATTER + , blinky = setGhost game.blinky blinkyScatterTarget + , pinky = setGhost game.pinky pinkyScatterTarget + , inky = setGhost game.inky inkyScatterTarget + , clyde = setGhost game.clyde clydeScatterTarget + } + | otherwise = + game + { gMode = CHASE + , blinky = setGhost game.blinky (x', y') + , pinky = setGhost game.pinky (x' + 3, y' + 3) + , inky = setGhost game.inky targetI + , clyde = setGhost game.clyde targetC + } + where + curTime = game.time + (x, y) = game.pacman.location + x' = roundF x + y' = roundF y + targetI = targetInky game + targetC = targetClyde game + setGhost g t = g{gTarget = t} + + +ghostModeSwitch :: PacGame -> PacGame +ghostModeSwitch game + | curMode == SCATTER || curMode == CHASE = ghostModeTimer game + | frTime >= frightenLength = ghostModeTimer game + | frTime < frightenLength = game{fTime = frTime + 1 / fromIntegral fps} + | otherwise = game + where + curMode = game.gMode + frTime = game.fTime + + +releaseInky :: PacGame -> PacGame +releaseInky game = + if curTime > 4 + && dotsLeft >= 10 + && (px_py == (-1, 0) || px_py == (0, 0) || px_py == (1, 0)) + then + game + { inky = + game.inky + { gSpeed = (0, 0) + , gLocation = (0, 2) + , gLastMove = STOP + , gDirection = STOP + } + } + else game + where + curTime = game.time + dotsLeft = listLength pelletsL - listLength (game.pellets) + px_py = game.inky.gLocation + + +releaseClyde :: PacGame -> PacGame +releaseClyde game = + if curTime > 4 + && dotsLeft >= 50 + && ((cx', cy') == (-1, 0) || (cx', cy') == (0, 0) || (cx', cy') == (1, 0)) + then + game + { clyde = + game.clyde + { gSpeed = (0, 0) + , gLocation = (0, 2) + , gLastMove = STOP + , gDirection = STOP + } + } + else game + where + curTime = game.time + dotsLeft = listLength pelletsL - listLength (game.pellets) + (cx, cy) = game.clyde.gLocation + cx' = roundF cx + cy' = roundF cy + + +releasePinky :: PacGame -> PacGame +releasePinky game = + if curTime > 4 && posPinky == (0, 0) + then + game + { pinky = + game.pinky + { gSpeed = (0, 0) + , gLocation = (0, 2) + , gLastMove = STOP + , gDirection = STOP + } + } + else game + where + curTime = game.time + posPinky = game.pinky.gLocation + + +distance :: Point -> Point -> Float +distance (x1, y1) (x2, y2) = sqrt (dx * dx + dy * dy) + where + dx = x2 - x1 + dy = y2 - y1 + + +ghostCollision :: PacGame -> PacGame +ghostCollision game + | (x', y') == (bx', by') = checkLives + | (x', y') == (px', py') = checkLives + | (x', y') == (ix', iy') = checkLives + | (x', y') == (cx', cy') = checkLives + | otherwise = game + where + (x, y) = game.pacman.location + x' = roundF x + y' = roundF y + (bx, by) = game.blinky.gLocation + (px, py) = game.pinky.gLocation + (ix, iy) = game.inky.gLocation + (cx, cy) = game.clyde.gLocation + bx' = roundF bx + by' = roundF by + px' = roundF px + py' = roundF py + ix' = roundF ix + iy' = roundF iy + cx' = roundF cx + cy' = roundF cy + curLives = game.lives + checkLives = + if curLives > 1 + then + game + { gMode = SCATTER + , lcrB = (0, 0) + , lcrP = (0, 0) + , lcrI = (0, 0) + , lcrC = (0, 0) + , time = 0.0 + , direction = STOP + , bufDirection = STOP + , lives = curLives - 1 + , pacman = Characters{cName = Pacman, speed = (0, 0), location = (0, -6)} + , pinky = + Ghost + { gName = Pinky + , gSpeed = (0, 0) + , gLocation = (0, 0) + , gTarget = pinkyScatterTarget + , gLastMove = STOP + , gDirection = STOP + } + , inky = + Ghost + { gName = Inky + , gSpeed = (0, 0) + , gLocation = (-1, 0) + , gTarget = inkyScatterTarget + , gLastMove = STOP + , gDirection = STOP + } + , blinky = + Ghost + { gName = Blinky + , gSpeed = (0, 0) + , gLocation = (0, 2) + , gTarget = blinkyScatterTarget + , gLastMove = STOP + , gDirection = STOP + } + , clyde = + Ghost + { gName = Clyde + , gSpeed = (0, 0) + , gLocation = (1, 0) + , gTarget = clydeScatterTarget + , gLastMove = STOP + , gDirection = STOP + } + } + else game{gameStatus = LOST} + + +ghostCollisionSwitch :: PacGame -> PacGame +ghostCollisionSwitch game + | mode == FRIGHTENED = case checkEaten game of + 1 -> eatBlinky + 2 -> eatPinky + 3 -> eatInky + 4 -> eatClyde + _ -> game + | otherwise = ghostCollision game + where + eatBlinky = + game + { blinky = + game.blinky + { gSpeed = (0, 0) + , gTarget = (0, 0) + , gLastMove = STOP + , gDirection = STOP + } + } + eatPinky = + game + { pinky = + game.pinky + { gSpeed = (0, 0) + , gTarget = (0, 0) + , gLastMove = STOP + , gDirection = STOP + } + } + eatInky = + game + { inky = + game.inky + { gSpeed = (0, 0) + , gTarget = (0, 0) + , gLastMove = STOP + , gDirection = STOP + } + } + eatClyde = + game + { clyde = + game.clyde + { gSpeed = (0, 0) + , gTarget = (0, 0) + , gLastMove = STOP + , gDirection = STOP + } + } + mode = game.gMode + + +checkEaten :: PacGame -> Int +checkEaten game + | (x', y') == (bx', by') = 1 + | (x', y') == (px', py') = 2 + | (x', y') == (ix', iy') = 3 + | (x', y') == (cx', cy') = 4 + | otherwise = 5 + where + (x, y) = game.pacman.location + x' = roundF x + y' = roundF y + (bx, by) = game.blinky.gLocation + (px, py) = game.pinky.gLocation + (ix, iy) = game.inky.gLocation + (cx, cy) = game.clyde.gLocation + bx' = roundF bx + by' = roundF by + px' = roundF px + py' = roundF py + ix' = roundF ix + iy' = roundF iy + cx' = roundF cx + cy' = roundF cy + + +-------------------- BLINKY ------------------ + +moveToTargetB :: PacGame -> PacGame +moveToTargetB game + | curTime <= 3 = game + | elem (x', y') crossR && lastCR /= (x', y') = + game + { lcrB = (x', y') + , blinky = game.blinky{gSpeed = (0, 0), gLocation = (x, y)} + } + | (vx, vy) == (0, 0) = case bWalls of + 1 -> b1 + 2 -> b2 + 3 -> b3 + 4 -> b4 + 5 -> b5 + _ -> b10 + | (vx, vy) /= (0, 0) = case game.blinky.gDirection of + UP -> testUp + DOWN -> testDown + LEFT -> testLeft + RIGHT -> testRight + STOP -> stop + | otherwise = game + where + (tx, ty) = game.blinky.gTarget + (vx, vy) = game.blinky.gSpeed + (x, y) = game.blinky.gLocation + x' = roundF x + y' = roundF y + yU = y' + 1 + yD = y' - 1 + xL = x' - 1 + xR = x' + 1 + lastCR = game.lcrB + curTarget = game.blinky.gTarget + lm = game.blinky.gLastMove + cD = game.blinky.gDirection + curTime = game.time + + b1 = + if lm /= UP + && distance (x', yU) (tx, ty) < distance (x', yD) (tx, ty) + && distance (x', yU) (tx, ty) < distance (xR, y') (tx, ty) + && distance (x', yU) (tx, ty) < distance (xL, y') (tx, ty) + then goUp + else + if lm /= DOWN + && distance (x', yD) (tx, ty) < distance (x', yU) (tx, ty) + && distance (x', yD) (tx, ty) < distance (xR, y') (tx, ty) + && distance (x', yD) (tx, ty) < distance (xL, y') (tx, ty) + then goDown + else + if lm /= RIGHT + && distance (xR, y') (tx, ty) < distance (x', yU) (tx, ty) + && distance (xR, y') (tx, ty) < distance (xL, y') (tx, ty) + && distance (xR, y') (tx, ty) < distance (x', yD) (tx, ty) + then goRight + else + if lm /= LEFT + && distance (xL, y') (tx, ty) < distance (x', yU) (tx, ty) + && distance (xL, y') (tx, ty) < distance (xR, y') (tx, ty) + && distance (xL, y') (tx, ty) < distance (x', yD) (tx, ty) + then goLeft + else + if lm /= RIGHT && checkInList (xR, y') coords + then goRight + else + if lm /= UP && checkInList (x', yU) coords + then goUp + else + if lm /= LEFT && checkInList (xL, y') coords + then goLeft + else + if lm /= DOWN && checkInList (x', yD) coords + then goDown + else game + + b2 = + if lm /= UP + && distance (x', yU) (tx, ty) <= distance (xR, y') (tx, ty) + && distance (x', yU) (tx, ty) <= distance (xL, y') (tx, ty) + then goUp + else + if lm /= RIGHT + && distance (xR, y') (tx, ty) <= distance (x', yU) (tx, ty) + && distance (xR, y') (tx, ty) <= distance (xL, y') (tx, ty) + then goRight + else + if lm /= LEFT + && distance (xL, y') (tx, ty) <= distance (x', yU) (tx, ty) + && distance (xL, y') (tx, ty) <= distance (xR, y') (tx, ty) + then goLeft + else + if lm /= UP && checkInList (x', yU) coords + then goUp + else + if lm /= RIGHT && checkInList (xR, y') coords + then goRight + else + if lm /= LEFT && checkInList (xL, y') coords + then goLeft + else + if lm /= DOWN && checkInList (x', yD) coords + then goDown + else game + + b3 = + if lm /= UP + && distance (x', yU) (tx, ty) < distance (x', yD) (tx, ty) + && distance (x', yU) (tx, ty) < distance (xR, y') (tx, ty) + then goUp + else + if lm /= DOWN + && distance (x', yD) (tx, ty) < distance (x', yU) (tx, ty) + && distance (x', yD) (tx, ty) < distance (xR, y') (tx, ty) + then goDown + else + if lm /= RIGHT + && distance (xR, y') (tx, ty) < distance (x', yU) (tx, ty) + && distance (xR, y') (tx, ty) < distance (x', yD) (tx, ty) + then goRight + else + if lm /= RIGHT && checkInList (xR, y') coords + then goRight + else + if lm /= UP && checkInList (x', yU) coords + then goUp + else + if lm /= LEFT && checkInList (xL, y') coords + then goLeft + else + if lm /= DOWN && checkInList (x', yD) coords + then goDown + else game + + b4 = + if lm /= DOWN + && distance (x', yD) (tx, ty) < distance (xR, y') (tx, ty) + && distance (x', yD) (tx, ty) < distance (xL, y') (tx, ty) + then goDown + else + if lm /= RIGHT + && distance (xR, y') (tx, ty) < distance (xL, y') (tx, ty) + && distance (xR, y') (tx, ty) < distance (x', yD) (tx, ty) + then goRight + else + if lm /= LEFT + && distance (xL, y') (tx, ty) < distance (xR, y') (tx, ty) + && distance (xL, y') (tx, ty) < distance (x', yD) (tx, ty) + then goLeft + else + if lm /= RIGHT && checkInList (xR, y') coords + then goRight + else + if lm /= UP && checkInList (x', yU) coords + then goUp + else + if lm /= LEFT && checkInList (xL, y') coords + then goLeft + else + if lm /= DOWN && checkInList (x', yD) coords + then goDown + else game + + b5 = + if lm /= UP + && distance (x', yU) (tx, ty) < distance (x', yD) (tx, ty) + && distance (x', yU) (tx, ty) < distance (xL, y') (tx, ty) + then goUp + else + if lm /= DOWN + && distance (x', yD) (tx, ty) < distance (x', yU) (tx, ty) + && distance (x', yD) (tx, ty) < distance (xL, y') (tx, ty) + then goDown + else + if lm /= LEFT + && distance (xL, y') (tx, ty) < distance (x', yU) (tx, ty) + && distance (xL, y') (tx, ty) < distance (x', yD) (tx, ty) + then goLeft + else + if lm /= RIGHT && checkInList (xR, y') coords + then goRight + else + if lm /= UP && checkInList (x', yU) coords + then goUp + else + if lm /= LEFT && checkInList (xL, y') coords + then goLeft + else + if lm /= DOWN && checkInList (x', yD) coords + then goDown + else game + + b10 = + if lm /= RIGHT && checkInList (xR, y') coords + then goRight + else + if lm /= UP && checkInList (x', yU) coords + then goUp + else + if lm /= LEFT && checkInList (xL, y') coords + then goLeft + else + if lm /= DOWN && checkInList (x', yD) coords + then goDown + else game + + bWalls = findWalls game 1 + + goRight = + game + { blinky = + Ghost + { gName = Blinky + , gSpeed = (3.7, 0) + , gLocation = (x', y') + , gTarget = curTarget + , gLastMove = LEFT + , gDirection = RIGHT + } + } + goLeft = + game + { blinky = + Ghost + { gName = Blinky + , gSpeed = (-3.7, 0) + , gLocation = (x', y') + , gTarget = curTarget + , gLastMove = RIGHT + , gDirection = LEFT + } + } + goUp = + game + { blinky = + Ghost + { gName = Blinky + , gSpeed = (0, 3.7) + , gLocation = (x', y') + , gTarget = curTarget + , gLastMove = DOWN + , gDirection = UP + } + } + goDown = + game + { blinky = + Ghost + { gName = Blinky + , gSpeed = (0, -3.7) + , gLocation = (x', y') + , gTarget = curTarget + , gLastMove = UP + , gDirection = DOWN + } + } + + testUp = + if elem (x', yU) coords + then + game + { blinky = + Ghost + { gName = Blinky + , gSpeed = (0, 0) + , gLocation = (x', y') + , gTarget = curTarget + , gLastMove = lm + , gDirection = cD + } + } + else game + testDown = + if elem (x', yD) coords + then + game + { blinky = + Ghost + { gName = Blinky + , gSpeed = (0, 0) + , gLocation = (x', y') + , gTarget = curTarget + , gLastMove = lm + , gDirection = cD + } + } + else game + testLeft = + if elem (xL, y') coords + then + game + { blinky = + Ghost + { gName = Blinky + , gSpeed = (0, 0) + , gLocation = (x', y') + , gTarget = curTarget + , gLastMove = lm + , gDirection = cD + } + } + else game + testRight = + if elem (xR, y') coords + then + game + { blinky = + Ghost + { gName = Blinky + , gSpeed = (0, 0) + , gLocation = (x', y') + , gTarget = curTarget + , gLastMove = lm + , gDirection = cD + } + } + else game + stop = + game + { blinky = + Ghost + { gName = Blinky + , gSpeed = (0, 0) + , gLocation = (x', y') + , gTarget = curTarget + , gLastMove = lm + , gDirection = cD + } + } + + +-------------------- PINKY ------------------ + +moveToTargetP :: PacGame -> PacGame +moveToTargetP game + | curTime <= 4 = game + | elem (x', y') crossR && lastCR /= (x', y') = + game{lcrP = (x', y'), pinky = game.pinky{gSpeed = (0, 0), gLocation = (x, y)}} + | (vx, vy) == (0, 0) = case pWalls of + 1 -> p1 + 2 -> p2 + 3 -> p3 + 4 -> p4 + 5 -> p5 + _ -> p10 + | (vx, vy) /= (0, 0) = case game.pinky.gDirection of + UP -> testUp + DOWN -> testDown + LEFT -> testLeft + RIGHT -> testRight + STOP -> stop + | otherwise = game + where + (tx, ty) = game.pinky.gTarget + (vx, vy) = game.pinky.gSpeed + (x, y) = game.pinky.gLocation + x' = roundF x + y' = roundF y + yU = y' + 1 + yD = y' - 1 + xL = x' - 1 + xR = x' + 1 + lastCR = game.lcrP + curTarget = game.pinky.gTarget + lm = game.pinky.gLastMove + cD = game.pinky.gDirection + curTime = game.time + + pWalls = findWalls game 2 + + p1 = + if lm /= UP + && distance (x', yU) (tx, ty) < distance (x', yD) (tx, ty) + && distance (x', yU) (tx, ty) < distance (xR, y') (tx, ty) + && distance (x', yU) (tx, ty) < distance (xL, y') (tx, ty) + then goUp + else + if lm /= DOWN + && distance (x', yD) (tx, ty) < distance (x', yU) (tx, ty) + && distance (x', yD) (tx, ty) < distance (xR, y') (tx, ty) + && distance (x', yD) (tx, ty) < distance (xL, y') (tx, ty) + then goDown + else + if lm /= RIGHT + && distance (xR, y') (tx, ty) < distance (x', yU) (tx, ty) + && distance (xR, y') (tx, ty) < distance (xL, y') (tx, ty) + && distance (xR, y') (tx, ty) < distance (x', yD) (tx, ty) + then goRight + else + if lm /= LEFT + && distance (xL, y') (tx, ty) < distance (x', yU) (tx, ty) + && distance (xL, y') (tx, ty) < distance (xR, y') (tx, ty) + && distance (xL, y') (tx, ty) < distance (x', yD) (tx, ty) + then goLeft + else + if lm /= RIGHT && checkInList (xR, y') coords + then goRight + else + if lm /= UP && checkInList (x', yU) coords + then goUp + else + if lm /= LEFT && checkInList (xL, y') coords + then goLeft + else + if lm /= DOWN && checkInList (x', yD) coords + then goDown + else game + + p2 = + if lm /= UP + && distance (x', yU) (tx, ty) <= distance (xR, y') (tx, ty) + && distance (x', yU) (tx, ty) <= distance (xL, y') (tx, ty) + then goUp + else + if lm /= RIGHT + && distance (xR, y') (tx, ty) <= distance (x', yU) (tx, ty) + && distance (xR, y') (tx, ty) <= distance (xL, y') (tx, ty) + then goRight + else + if lm /= LEFT + && distance (xL, y') (tx, ty) <= distance (x', yU) (tx, ty) + && distance (xL, y') (tx, ty) <= distance (xR, y') (tx, ty) + then goLeft + else + if lm /= UP && checkInList (x', yU) coords + then goUp + else + if lm /= RIGHT && checkInList (xR, y') coords + then goRight + else + if lm /= LEFT && checkInList (xL, y') coords + then goLeft + else + if lm /= DOWN && checkInList (x', yD) coords + then goDown + else game + + p3 = + if lm /= UP + && distance (x', yU) (tx, ty) < distance (x', yD) (tx, ty) + && distance (x', yU) (tx, ty) < distance (xR, y') (tx, ty) + then goUp + else + if lm /= DOWN + && distance (x', yD) (tx, ty) < distance (x', yU) (tx, ty) + && distance (x', yD) (tx, ty) < distance (xR, y') (tx, ty) + then goDown + else + if lm /= RIGHT + && distance (xR, y') (tx, ty) < distance (x', yU) (tx, ty) + && distance (xR, y') (tx, ty) < distance (x', yD) (tx, ty) + then goRight + else + if lm /= RIGHT && checkInList (xR, y') coords + then goRight + else + if lm /= UP && checkInList (x', yU) coords + then goUp + else + if lm /= LEFT && checkInList (xL, y') coords + then goLeft + else + if lm /= DOWN && checkInList (x', yD) coords + then goDown + else game + + p4 = + if lm /= DOWN + && distance (x', yD) (tx, ty) < distance (xR, y') (tx, ty) + && distance (x', yD) (tx, ty) < distance (xL, y') (tx, ty) + then goDown + else + if lm /= RIGHT + && distance (xR, y') (tx, ty) < distance (xL, y') (tx, ty) + && distance (xR, y') (tx, ty) < distance (x', yD) (tx, ty) + then goRight + else + if lm /= LEFT + && distance (xL, y') (tx, ty) < distance (xR, y') (tx, ty) + && distance (xL, y') (tx, ty) < distance (x', yD) (tx, ty) + then goLeft + else + if lm /= RIGHT && checkInList (xR, y') coords + then goRight + else + if lm /= UP && checkInList (x', yU) coords + then goUp + else + if lm /= LEFT && checkInList (xL, y') coords + then goLeft + else + if lm /= DOWN && checkInList (x', yD) coords + then goDown + else game + + p5 = + if lm /= UP + && distance (x', yU) (tx, ty) < distance (x', yD) (tx, ty) + && distance (x', yU) (tx, ty) < distance (xL, y') (tx, ty) + then goUp + else + if lm /= DOWN + && distance (x', yD) (tx, ty) < distance (x', yU) (tx, ty) + && distance (x', yD) (tx, ty) < distance (xL, y') (tx, ty) + then goDown + else + if lm /= LEFT + && distance (xL, y') (tx, ty) < distance (x', yU) (tx, ty) + && distance (xL, y') (tx, ty) < distance (x', yD) (tx, ty) + then goLeft + else + if lm /= RIGHT && checkInList (xR, y') coords + then goRight + else + if lm /= UP && checkInList (x', yU) coords + then goUp + else + if lm /= LEFT && checkInList (xL, y') coords + then goLeft + else + if lm /= DOWN && checkInList (x', yD) coords + then goDown + else game + + p10 = + if lm /= RIGHT && checkInList (xR, y') coords + then goRight + else + if lm /= UP && checkInList (x', yU) coords + then goUp + else + if lm /= LEFT && checkInList (xL, y') coords + then goLeft + else + if lm /= DOWN && checkInList (x', yD) coords + then goDown + else game + + goRight = + game + { pinky = + Ghost + { gName = Pinky + , gSpeed = (3.7, 0) + , gLocation = (x', y') + , gTarget = curTarget + , gLastMove = LEFT + , gDirection = RIGHT + } + } + goLeft = + game + { pinky = + Ghost + { gName = Pinky + , gSpeed = (-3.7, 0) + , gLocation = (x', y') + , gTarget = curTarget + , gLastMove = RIGHT + , gDirection = LEFT + } + } + goUp = + game + { pinky = + Ghost + { gName = Pinky + , gSpeed = (0, 3.7) + , gLocation = (x', y') + , gTarget = curTarget + , gLastMove = DOWN + , gDirection = UP + } + } + goDown = + game + { pinky = + Ghost + { gName = Pinky + , gSpeed = (0, -3.7) + , gLocation = (x', y') + , gTarget = curTarget + , gLastMove = UP + , gDirection = DOWN + } + } + + testUp = + if elem (x', yU) coords + then + game + { pinky = + Ghost + { gName = Pinky + , gSpeed = (0, 0) + , gLocation = (x', y') + , gTarget = curTarget + , gLastMove = lm + , gDirection = cD + } + } + else game + testDown = + if elem (x', yD) coords + then + game + { pinky = + Ghost + { gName = Pinky + , gSpeed = (0, 0) + , gLocation = (x', y') + , gTarget = curTarget + , gLastMove = lm + , gDirection = cD + } + } + else game + testLeft = + if elem (xL, y') coords + then + game + { pinky = + Ghost + { gName = Pinky + , gSpeed = (0, 0) + , gLocation = (x', y') + , gTarget = curTarget + , gLastMove = lm + , gDirection = cD + } + } + else game + testRight = + if elem (xR, y') coords + then + game + { pinky = + Ghost + { gName = Pinky + , gSpeed = (0, 0) + , gLocation = (x', y') + , gTarget = curTarget + , gLastMove = lm + , gDirection = cD + } + } + else game + stop = + game + { pinky = + Ghost + { gName = Pinky + , gSpeed = (0, 0) + , gLocation = (x', y') + , gTarget = curTarget + , gLastMove = lm + , gDirection = cD + } + } + + +-------------------- INKY ------------------ + +targetInky :: PacGame -> Point +targetInky game = case pacDirection of + UP -> up + DOWN -> down + LEFT -> left + RIGHT -> right + STOP -> up + where + (bx, by) = game.blinky.gLocation + bx' = roundF bx + by' = roundF by + pacDirection = game.direction + (px, py) = game.pacman.location + px' = roundF px + py' = roundF py + up = ((px' - bx') + px', ((py' + 1) - by') + py') + down = ((px' - bx') + px', ((py' - 1) - by') + py') + left = (((px' - 1) - bx') + px', (py' - by') + py') + right = (((px' + 1) - bx') + px', (py' - by') + py') + + +moveToTargetI :: PacGame -> PacGame +moveToTargetI game + | curTime <= 4 = game + | dotsLeft <= 10 = game + | elem (x', y') crossR && lastCR /= (x', y') = + game{lcrI = (x', y'), inky = game.inky{gSpeed = (0, 0), gLocation = (x, y)}} + | (vx, vy) == (0, 0) = case iWalls of + 1 -> p1 + 2 -> p2 + 3 -> p3 + 4 -> p4 + 5 -> p5 + _ -> p10 + | (vx, vy) /= (0, 0) = case game.inky.gDirection of + UP -> testUp + DOWN -> testDown + LEFT -> testLeft + RIGHT -> testRight + STOP -> stop + | otherwise = game + where + curPellets = game.pellets + dotsLeft = listLength pelletsL - listLength curPellets + (tx, ty) = game.inky.gTarget + (vx, vy) = game.inky.gSpeed + (x, y) = game.inky.gLocation + x' = roundF x + y' = roundF y + yU = y' + 1 + yD = y' - 1 + xL = x' - 1 + xR = x' + 1 + lastCR = game.lcrI + curTarget = game.inky.gTarget + lm = game.inky.gLastMove + cD = game.inky.gDirection + curTime = game.time + + iWalls = findWalls game 3 + + p1 = + if lm /= UP + && distance (x', yU) (tx, ty) < distance (x', yD) (tx, ty) + && distance (x', yU) (tx, ty) < distance (xR, y') (tx, ty) + && distance (x', yU) (tx, ty) < distance (xL, y') (tx, ty) + then goUp + else + if lm /= DOWN + && distance (x', yD) (tx, ty) < distance (x', yU) (tx, ty) + && distance (x', yD) (tx, ty) < distance (xR, y') (tx, ty) + && distance (x', yD) (tx, ty) < distance (xL, y') (tx, ty) + then goDown + else + if lm /= RIGHT + && distance (xR, y') (tx, ty) < distance (x', yU) (tx, ty) + && distance (xR, y') (tx, ty) < distance (xL, y') (tx, ty) + && distance (xR, y') (tx, ty) < distance (x', yD) (tx, ty) + then goRight + else + if lm /= LEFT + && distance (xL, y') (tx, ty) < distance (x', yU) (tx, ty) + && distance (xL, y') (tx, ty) < distance (xR, y') (tx, ty) + && distance (xL, y') (tx, ty) < distance (x', yD) (tx, ty) + then goLeft + else + if lm /= RIGHT && checkInList (xR, y') coords + then goRight + else + if lm /= UP && checkInList (x', yU) coords + then goUp + else + if lm /= LEFT && checkInList (xL, y') coords + then goLeft + else + if lm /= DOWN && checkInList (x', yD) coords + then goDown + else game + + p2 = + if lm /= UP + && distance (x', yU) (tx, ty) <= distance (xR, y') (tx, ty) + && distance (x', yU) (tx, ty) <= distance (xL, y') (tx, ty) + then goUp + else + if lm /= RIGHT + && distance (xR, y') (tx, ty) <= distance (x', yU) (tx, ty) + && distance (xR, y') (tx, ty) <= distance (xL, y') (tx, ty) + then goRight + else + if lm /= LEFT + && distance (xL, y') (tx, ty) <= distance (x', yU) (tx, ty) + && distance (xL, y') (tx, ty) <= distance (xR, y') (tx, ty) + then goLeft + else + if lm /= UP && checkInList (x', yU) coords + then goUp + else + if lm /= RIGHT && checkInList (xR, y') coords + then goRight + else + if lm /= LEFT && checkInList (xL, y') coords + then goLeft + else + if lm /= DOWN && checkInList (x', yD) coords + then goDown + else game + + p3 = + if lm /= UP + && distance (x', yU) (tx, ty) < distance (x', yD) (tx, ty) + && distance (x', yU) (tx, ty) < distance (xR, y') (tx, ty) + then goUp + else + if lm /= DOWN + && distance (x', yD) (tx, ty) < distance (x', yU) (tx, ty) + && distance (x', yD) (tx, ty) < distance (xR, y') (tx, ty) + then goDown + else + if lm /= RIGHT + && distance (xR, y') (tx, ty) < distance (x', yU) (tx, ty) + && distance (xR, y') (tx, ty) < distance (x', yD) (tx, ty) + then goRight + else + if lm /= RIGHT && checkInList (xR, y') coords + then goRight + else + if lm /= UP && checkInList (x', yU) coords + then goUp + else + if lm /= LEFT && checkInList (xL, y') coords + then goLeft + else + if lm /= DOWN && checkInList (x', yD) coords + then goDown + else game + + p4 = + if lm /= DOWN + && distance (x', yD) (tx, ty) < distance (xR, y') (tx, ty) + && distance (x', yD) (tx, ty) < distance (xL, y') (tx, ty) + then goDown + else + if lm /= RIGHT + && distance (xR, y') (tx, ty) < distance (xL, y') (tx, ty) + && distance (xR, y') (tx, ty) < distance (x', yD) (tx, ty) + then goRight + else + if lm /= LEFT + && distance (xL, y') (tx, ty) < distance (xR, y') (tx, ty) + && distance (xL, y') (tx, ty) < distance (x', yD) (tx, ty) + then goLeft + else + if lm /= RIGHT && checkInList (xR, y') coords + then goRight + else + if lm /= UP && checkInList (x', yU) coords + then goUp + else + if lm /= LEFT && checkInList (xL, y') coords + then goLeft + else + if lm /= DOWN && checkInList (x', yD) coords + then goDown + else game + + p5 = + if lm /= UP + && distance (x', yU) (tx, ty) < distance (x', yD) (tx, ty) + && distance (x', yU) (tx, ty) < distance (xL, y') (tx, ty) + then goUp + else + if lm /= DOWN + && distance (x', yD) (tx, ty) < distance (x', yU) (tx, ty) + && distance (x', yD) (tx, ty) < distance (xL, y') (tx, ty) + then goDown + else + if lm /= LEFT + && distance (xL, y') (tx, ty) < distance (x', yU) (tx, ty) + && distance (xL, y') (tx, ty) < distance (x', yD) (tx, ty) + then goLeft + else + if lm /= RIGHT && checkInList (xR, y') coords + then goRight + else + if lm /= UP && checkInList (x', yU) coords + then goUp + else + if lm /= LEFT && checkInList (xL, y') coords + then goLeft + else + if lm /= DOWN && checkInList (x', yD) coords + then goDown + else game + + p10 = + if lm /= RIGHT && checkInList (xR, y') coords + then goRight + else + if lm /= UP && checkInList (x', yU) coords + then goUp + else + if lm /= LEFT && checkInList (xL, y') coords + then goLeft + else + if lm /= DOWN && checkInList (x', yD) coords + then goDown + else game + + goRight = + game + { inky = + Ghost + { gName = Inky + , gSpeed = (3.7, 0) + , gLocation = (x', y') + , gTarget = curTarget + , gLastMove = LEFT + , gDirection = RIGHT + } + } + goLeft = + game + { inky = + Ghost + { gName = Inky + , gSpeed = (-3.7, 0) + , gLocation = (x', y') + , gTarget = curTarget + , gLastMove = RIGHT + , gDirection = LEFT + } + } + goUp = + game + { inky = + Ghost + { gName = Inky + , gSpeed = (0, 3.7) + , gLocation = (x', y') + , gTarget = curTarget + , gLastMove = DOWN + , gDirection = UP + } + } + goDown = + game + { inky = + Ghost + { gName = Inky + , gSpeed = (0, -3.7) + , gLocation = (x', y') + , gTarget = curTarget + , gLastMove = UP + , gDirection = DOWN + } + } + + testUp = + if elem (x', yU) coords + then + game + { inky = + Ghost + { gName = Inky + , gSpeed = (0, 0) + , gLocation = (x', y') + , gTarget = curTarget + , gLastMove = lm + , gDirection = cD + } + } + else game + testDown = + if elem (x', yD) coords + then + game + { inky = + Ghost + { gName = Inky + , gSpeed = (0, 0) + , gLocation = (x', y') + , gTarget = curTarget + , gLastMove = lm + , gDirection = cD + } + } + else game + testLeft = + if elem (xL, y') coords + then + game + { inky = + Ghost + { gName = Inky + , gSpeed = (0, 0) + , gLocation = (x', y') + , gTarget = curTarget + , gLastMove = lm + , gDirection = cD + } + } + else game + testRight = + if elem (xR, y') coords + then + game + { inky = + Ghost + { gName = Inky + , gSpeed = (0, 0) + , gLocation = (x', y') + , gTarget = curTarget + , gLastMove = lm + , gDirection = cD + } + } + else game + stop = + game + { inky = + Ghost + { gName = Inky + , gSpeed = (0, 0) + , gLocation = (x', y') + , gTarget = curTarget + , gLastMove = lm + , gDirection = cD + } + } + + +-------------------- CLYDE ------------------ + +targetClyde :: PacGame -> Point +targetClyde game + | (px' - cx' <= 4) || (py' - cy' <= 4) = clydeScatterTarget + | otherwise = (px', py') + where + (px, py) = game.pacman.location + px' = roundF px + py' = roundF py + (cx, cy) = game.clyde.gLocation + cx' = roundF cx + cy' = roundF cy + + +moveToTargetC :: PacGame -> PacGame +moveToTargetC game + | curTime <= 3 = game + | dotsLeft <= 50 = game + | elem (x', y') crossR && lastCR /= (x', y') = + game{lcrC = (x', y'), clyde = game.clyde{gSpeed = (0, 0), gLocation = (x, y)}} + | (vx, vy) == (0, 0) = case cWalls of + 1 -> c1 + 2 -> c2 + 3 -> c3 + 4 -> c4 + 5 -> c5 + _ -> c10 + | (vx, vy) /= (0, 0) = case game.clyde.gDirection of + UP -> testUp + DOWN -> testDown + LEFT -> testLeft + RIGHT -> testRight + STOP -> stop + | otherwise = game + where + curPellets = game.pellets + dotsLeft = listLength pelletsL - listLength curPellets + (tx, ty) = game.clyde.gTarget + (vx, vy) = game.clyde.gSpeed + (x, y) = game.clyde.gLocation + x' = roundF x + y' = roundF y + yU = y' + 1 + yD = y' - 1 + xL = x' - 1 + xR = x' + 1 + lastCR = game.lcrC + curTarget = game.clyde.gTarget + lm = game.clyde.gLastMove + cD = game.clyde.gDirection + curTime = game.time + + c1 = + if lm /= UP + && distance (x', yU) (tx, ty) < distance (x', yD) (tx, ty) + && distance (x', yU) (tx, ty) < distance (xR, y') (tx, ty) + && distance (x', yU) (tx, ty) < distance (xL, y') (tx, ty) + then goUp + else + if lm /= DOWN + && distance (x', yD) (tx, ty) < distance (x', yU) (tx, ty) + && distance (x', yD) (tx, ty) < distance (xR, y') (tx, ty) + && distance (x', yD) (tx, ty) < distance (xL, y') (tx, ty) + then goDown + else + if lm /= RIGHT + && distance (xR, y') (tx, ty) < distance (x', yU) (tx, ty) + && distance (xR, y') (tx, ty) < distance (xL, y') (tx, ty) + && distance (xR, y') (tx, ty) < distance (x', yD) (tx, ty) + then goRight + else + if lm /= LEFT + && distance (xL, y') (tx, ty) < distance (x', yU) (tx, ty) + && distance (xL, y') (tx, ty) < distance (xR, y') (tx, ty) + && distance (xL, y') (tx, ty) < distance (x', yD) (tx, ty) + then goLeft + else + if lm /= RIGHT && checkInList (xR, y') coords + then goRight + else + if lm /= UP && checkInList (x', yU) coords + then goUp + else + if lm /= LEFT && checkInList (xL, y') coords + then goLeft + else + if lm /= DOWN && checkInList (x', yD) coords + then goDown + else game + + c2 = + if lm /= UP + && distance (x', yU) (tx, ty) <= distance (xR, y') (tx, ty) + && distance (x', yU) (tx, ty) <= distance (xL, y') (tx, ty) + then goUp + else + if lm /= RIGHT + && distance (xR, y') (tx, ty) <= distance (x', yU) (tx, ty) + && distance (xR, y') (tx, ty) <= distance (xL, y') (tx, ty) + then goRight + else + if lm /= LEFT + && distance (xL, y') (tx, ty) <= distance (x', yU) (tx, ty) + && distance (xL, y') (tx, ty) <= distance (xR, y') (tx, ty) + then goLeft + else + if lm /= UP && checkInList (x', yU) coords + then goUp + else + if lm /= RIGHT && checkInList (xR, y') coords + then goRight + else + if lm /= LEFT && checkInList (xL, y') coords + then goLeft + else + if lm /= DOWN && checkInList (x', yD) coords + then goDown + else game + + c3 = + if lm /= UP + && distance (x', yU) (tx, ty) < distance (x', yD) (tx, ty) + && distance (x', yU) (tx, ty) < distance (xR, y') (tx, ty) + then goUp + else + if lm /= DOWN + && distance (x', yD) (tx, ty) < distance (x', yU) (tx, ty) + && distance (x', yD) (tx, ty) < distance (xR, y') (tx, ty) + then goDown + else + if lm /= RIGHT + && distance (xR, y') (tx, ty) < distance (x', yU) (tx, ty) + && distance (xR, y') (tx, ty) < distance (x', yD) (tx, ty) + then goRight + else + if lm /= RIGHT && checkInList (xR, y') coords + then goRight + else + if lm /= UP && checkInList (x', yU) coords + then goUp + else + if lm /= LEFT && checkInList (xL, y') coords + then goLeft + else + if lm /= DOWN && checkInList (x', yD) coords + then goDown + else game + + c4 = + if lm /= DOWN + && distance (x', yD) (tx, ty) < distance (xR, y') (tx, ty) + && distance (x', yD) (tx, ty) < distance (xL, y') (tx, ty) + then goDown + else + if lm /= RIGHT + && distance (xR, y') (tx, ty) < distance (xL, y') (tx, ty) + && distance (xR, y') (tx, ty) < distance (x', yD) (tx, ty) + then goRight + else + if lm /= LEFT + && distance (xL, y') (tx, ty) < distance (xR, y') (tx, ty) + && distance (xL, y') (tx, ty) < distance (x', yD) (tx, ty) + then goLeft + else + if lm /= RIGHT && checkInList (xR, y') coords + then goRight + else + if lm /= UP && checkInList (x', yU) coords + then goUp + else + if lm /= LEFT && checkInList (xL, y') coords + then goLeft + else + if lm /= DOWN && checkInList (x', yD) coords + then goDown + else game + + c5 = + if lm /= UP + && distance (x', yU) (tx, ty) < distance (x', yD) (tx, ty) + && distance (x', yU) (tx, ty) < distance (xL, y') (tx, ty) + then goUp + else + if lm /= DOWN + && distance (x', yD) (tx, ty) < distance (x', yU) (tx, ty) + && distance (x', yD) (tx, ty) < distance (xL, y') (tx, ty) + then goDown + else + if lm /= LEFT + && distance (xL, y') (tx, ty) < distance (x', yU) (tx, ty) + && distance (xL, y') (tx, ty) < distance (x', yD) (tx, ty) + then goLeft + else + if lm /= RIGHT && checkInList (xR, y') coords + then goRight + else + if lm /= UP && checkInList (x', yU) coords + then goUp + else + if lm /= LEFT && checkInList (xL, y') coords + then goLeft + else + if lm /= DOWN && checkInList (x', yD) coords + then goDown + else game + + c10 = + if lm /= RIGHT && checkInList (xR, y') coords + then goRight + else + if lm /= UP && checkInList (x', yU) coords + then goUp + else + if lm /= LEFT && checkInList (xL, y') coords + then goLeft + else + if lm /= DOWN && checkInList (x', yD) coords + then goDown + else game + + cWalls = findWalls game 4 + + goRight = + game + { clyde = + Ghost + { gName = Clyde + , gSpeed = (3.7, 0) + , gLocation = (x', y') + , gTarget = curTarget + , gLastMove = LEFT + , gDirection = RIGHT + } + } + goLeft = + game + { clyde = + Ghost + { gName = Clyde + , gSpeed = (-3.7, 0) + , gLocation = (x', y') + , gTarget = curTarget + , gLastMove = RIGHT + , gDirection = LEFT + } + } + goUp = + game + { clyde = + Ghost + { gName = Clyde + , gSpeed = (0, 3.7) + , gLocation = (x', y') + , gTarget = curTarget + , gLastMove = DOWN + , gDirection = UP + } + } + goDown = + game + { clyde = + Ghost + { gName = Clyde + , gSpeed = (0, -3.7) + , gLocation = (x', y') + , gTarget = curTarget + , gLastMove = UP + , gDirection = DOWN + } + } + + testUp = + if elem (x', yU) coords + then + game + { clyde = + Ghost + { gName = Clyde + , gSpeed = (0, 0) + , gLocation = (x', y') + , gTarget = curTarget + , gLastMove = lm + , gDirection = cD + } + } + else game + testDown = + if elem (x', yD) coords + then + game + { clyde = + Ghost + { gName = Clyde + , gSpeed = (0, 0) + , gLocation = (x', y') + , gTarget = curTarget + , gLastMove = lm + , gDirection = cD + } + } + else game + testLeft = + if elem (xL, y') coords + then + game + { clyde = + Ghost + { gName = Clyde + , gSpeed = (0, 0) + , gLocation = (x', y') + , gTarget = curTarget + , gLastMove = lm + , gDirection = cD + } + } + else game + testRight = + if elem (xR, y') coords + then + game + { clyde = + Ghost + { gName = Clyde + , gSpeed = (0, 0) + , gLocation = (x', y') + , gTarget = curTarget + , gLastMove = lm + , gDirection = cD + } + } + else game + stop = + game + { clyde = + Ghost + { gName = Clyde + , gSpeed = (0, 0) + , gLocation = (x', y') + , gTarget = curTarget + , gLastMove = lm + , gDirection = cD + } + } + + +-- Wall configuration codes: +-- 1 = all 4 sides open +-- 2 = left, up, right open (down wall) +-- 3 = up, right, down open (left wall) +-- 4 = right, down, left open (up wall) +-- 5 = down, left, up open (right wall) +-- 10 = fallback +findWalls :: PacGame -> Int -> Int +findWalls game x = case x of + 1 -> checkBlinky + 2 -> checkPinky + 3 -> checkInky + 4 -> checkClyde + _ -> 10 + where + --- Blinky --- + (bx, by) = game.blinky.gLocation + bx' = roundF bx + by' = roundF by + bU = by' + 1 + bD = by' - 1 + bL = bx' - 1 + bR = bx' + 1 + checkBlinky = + if checkInList (bL, by') coords + && checkInList (bR, by') coords + && checkInList (bx', bU) coords + && checkInList (bx', bD) coords + then 1 + else + if checkInList (bL, by') coords + && checkInList (bR, by') coords + && checkInList (bx', bU) coords + && elem (bx', bD) coords + then 2 + else + if elem (bL, by') coords + && checkInList (bR, by') coords + && checkInList (bx', bU) coords + && checkInList (bx', bD) coords + then 3 + else + if checkInList (bL, by') coords + && checkInList (bR, by') coords + && elem (bx', bU) coords + && checkInList (bx', bD) coords + then 4 + else + if checkInList (bL, by') coords + && elem (bR, by') coords + && checkInList (bx', bU) coords + && checkInList (bx', bD) coords + then 5 + else 10 + + --- Pinky --- + (px, py) = game.pinky.gLocation + px' = roundF px + py' = roundF py + pU = py' + 1 + pD = py' - 1 + pL = px' - 1 + pR = px' + 1 + checkPinky = + if checkInList (pL, py') coords + && checkInList (pR, py') coords + && checkInList (px', pU) coords + && checkInList (px', pD) coords + then 1 + else + if checkInList (pL, py') coords + && checkInList (pR, py') coords + && checkInList (px', pU) coords + && elem (px', pD) coords + then 2 + else + if elem (pL, py') coords + && checkInList (pR, py') coords + && checkInList (px', pU) coords + && checkInList (px', pD) coords + then 3 + else + if checkInList (pL, py') coords + && checkInList (pR, py') coords + && elem (px', pU) coords + && checkInList (px', pD) coords + then 4 + else + if checkInList (pL, py') coords + && elem (pR, py') coords + && checkInList (px', pU) coords + && checkInList (px', pD) coords + then 5 + else 10 + + --- Inky --- + (ix, iy) = game.inky.gLocation + ix' = roundF ix + iy' = roundF iy + iU = iy' + 1 + iD = iy' - 1 + iL = ix' - 1 + iR = ix' + 1 + checkInky = + if checkInList (iL, iy') coords + && checkInList (iR, iy') coords + && checkInList (ix', iU) coords + && checkInList (ix', iD) coords + then 1 + else + if checkInList (iL, iy') coords + && checkInList (iR, iy') coords + && checkInList (ix', iU) coords + && elem (ix', iD) coords + then 2 + else + if elem (iL, iy') coords + && checkInList (iR, iy') coords + && checkInList (ix', iU) coords + && checkInList (ix', iD) coords + then 3 + else + if checkInList (iL, iy') coords + && checkInList (iR, iy') coords + && elem (ix', iU) coords + && checkInList (ix', iD) coords + then 4 + else + if checkInList (iL, iy') coords + && elem (iR, iy') coords + && checkInList (ix', iU) coords + && checkInList (ix', iD) coords + then 5 + else 10 + + --- Clyde --- + (cx, cy) = game.clyde.gLocation + cx' = roundF cx + cy' = roundF cy + cU = cy' + 1 + cD' = cy' - 1 + cL = cx' - 1 + cR = cx' + 1 + checkClyde = + if checkInList (cL, cy') coords + && checkInList (cR, cy') coords + && checkInList (cx', cU) coords + && checkInList (cx', cD') coords + then 1 + else + if checkInList (cL, cy') coords + && checkInList (cR, cy') coords + && checkInList (cx', cU) coords + && elem (cx', cD') coords + then 2 + else + if elem (cL, cy') coords + && checkInList (cR, cy') coords + && checkInList (cx', cU) coords + && checkInList (cx', cD') coords + then 3 + else + if checkInList (cL, cy') coords + && checkInList (cR, cy') coords + && elem (cx', cU) coords + && checkInList (cx', cD') coords + then 4 + else + if checkInList (cL, cy') coords + && elem (cR, cy') coords + && checkInList (cx', cU) coords + && checkInList (cx', cD') coords + then 5 + else 10 diff --git a/picture/PacMan/Main.hs b/picture/PacMan/Main.hs new file mode 100644 --- /dev/null +++ b/picture/PacMan/Main.hs @@ -0,0 +1,476 @@ +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} + +module Main (main) where + +import Brillo +import Brillo.Interface.Pure.Game +import Data.Fixed (mod') +import Data.Text qualified as T + +import GhostAI ( + ghostCollisionSwitch, + ghostModeSwitch, + listLength, + moveToTargetB, + moveToTargetC, + moveToTargetI, + moveToTargetP, + releaseClyde, + releaseInky, + releasePinky, + roundF, + ) +import Maze +import Structs + + +handleKeys :: Event -> PacGame -> PacGame +handleKeys event game + | curTime < 3 = game + | otherwise = case event of + EventKey (SpecialKey KeyUp) _ _ _ -> game{bufDirection = UP} + EventKey (SpecialKey KeyDown) _ _ _ -> game{bufDirection = DOWN} + EventKey (SpecialKey KeyLeft) _ _ _ -> game{bufDirection = LEFT} + EventKey (SpecialKey KeyRight) _ _ _ -> game{bufDirection = RIGHT} + EventKey (Char 'w') _ _ _ -> game{bufDirection = UP} + EventKey (Char 's') _ _ _ -> game{bufDirection = DOWN} + EventKey (Char 'a') _ _ _ -> game{bufDirection = LEFT} + EventKey (Char 'd') _ _ _ -> game{bufDirection = RIGHT} + _ -> game + where + curTime = game.time + + +initialize :: PacGame +initialize = + Game + { lives = 3 + , gameStatus = PLAYING + , pacman = Characters{cName = Pacman, speed = (0, 0), location = (0, -6)} + , pinky = + Ghost + { gName = Pinky + , gSpeed = (0, 0) + , gLocation = (0, 0) + , gTarget = pinkyScatterTarget + , gLastMove = STOP + , gDirection = STOP + } + , inky = + Ghost + { gName = Inky + , gSpeed = (0, 0) + , gLocation = (-1, 0) + , gTarget = inkyScatterTarget + , gLastMove = STOP + , gDirection = STOP + } + , blinky = + Ghost + { gName = Blinky + , gSpeed = (0, 0) + , gLocation = (0, 2) + , gTarget = blinkyScatterTarget + , gLastMove = STOP + , gDirection = STOP + } + , clyde = + Ghost + { gName = Clyde + , gSpeed = (0, 0) + , gLocation = (1, 0) + , gTarget = clydeScatterTarget + , gLastMove = STOP + , gDirection = STOP + } + , time = 0.0 + , score = 0 + , pellets = pelletsL + , direction = LEFT + , bufDirection = STOP + , gMode = SCATTER + , lcrB = (0, 0) + , lcrP = (0, 0) + , lcrI = (0, 0) + , lcrC = (0, 0) + , pPellets = powerPellet + , fTime = 0.0 + } + + +beginTimer :: PacGame -> PacGame +beginTimer game = game{time = curTime + 1 / fromIntegral fps} + where + curTime = game.time + + +renderPacman :: PacGame -> Picture +renderPacman game = + Translate (x * 30) (y * 30) $ + Rotate rot $ + Color yellow $ + arcSolid mouth (360 - mouth) 13 + where + (x, y) = game.pacman.location + mouth = 5 + 40 * abs (sin (game.time * 8)) + rot = case game.direction of + RIGHT -> 0 + UP -> -90 + LEFT -> 180 + DOWN -> 90 + STOP -> 0 + + +renderGhost :: Color -> Point -> Picture +renderGhost clr (x, y) = + Translate (x * 30) (y * 30) $ Color clr $ circleSolid 13 + + +renderPinky :: PacGame -> Picture +renderPinky game + | mode == CHASE || mode == SCATTER = renderGhost (light rose) pos + | target == (0, 0) = renderGhost (dark white) pos + | otherwise = renderGhost blue pos + where + pos = game.pinky.gLocation + mode = game.gMode + target = game.pinky.gTarget + + +renderInky :: PacGame -> Picture +renderInky game + | mode == CHASE || mode == SCATTER = renderGhost cyan pos + | target == (0, 0) = renderGhost (dark white) pos + | otherwise = renderGhost blue pos + where + pos = game.inky.gLocation + mode = game.gMode + target = game.inky.gTarget + + +renderBlinky :: PacGame -> Picture +renderBlinky game + | mode == CHASE || mode == SCATTER = renderGhost red pos + | target == (0, 0) = renderGhost (dark white) pos + | otherwise = renderGhost blue pos + where + pos = game.blinky.gLocation + mode = game.gMode + target = game.blinky.gTarget + + +renderClyde :: PacGame -> Picture +renderClyde game + | mode == CHASE || mode == SCATTER = renderGhost orange pos + | target == (0, 0) = renderGhost (dark white) pos + | otherwise = renderGhost blue pos + where + pos = game.clyde.gLocation + mode = game.gMode + target = game.clyde.gTarget + + +renderStuff :: PacGame -> Picture +renderStuff game + | curTime <= 3 = + Translate (-30) (-65) $ Scale 0.15 0.15 $ Color yellow $ Text "Ready!" + | otherwise = + Color white $ + Scale 0.2 0.2 $ + Pictures [rScore, rLives, modeText] + where + rScore = Translate (-1400) 1475 $ Text $ T.pack $ "Score: " ++ show game.score + rLives = Translate (-1800) (-1880) $ Text "Lives: " + modeText = Translate 200 1475 $ Text $ T.pack $ "Mode: " ++ show game.gMode + curTime = game.time + + +renderPellets :: PacGame -> Picture +renderPellets game = + Pictures + [ Translate (x * 30) (y * 30) $ Color white $ circleSolid 4 + | (x, y) <- game.pellets + ] + + +renderPowerPellets :: PacGame -> Picture +renderPowerPellets game + | mod' curTime 0.3 >= 0 && mod' curTime 0.3 <= 0.15 = + Pictures + [ Translate (x * 30) (y * 30) $ Color white $ circleSolid 8 + | (x, y) <- game.pPellets + ] + | otherwise = Blank + where + curTime = game.time + + +renderLives :: PacGame -> Picture +renderLives game + | curTime <= 3 = Blank + | curLives >= 3 = Pictures [renderOne, renderTwo, renderThree] + | curLives == 2 = Pictures [renderOne, renderTwo] + | curLives == 1 = Pictures [renderOne] + | otherwise = Blank + where + curTime = game.time + curLives = game.lives + renderOne = Translate (-270) (-370) $ Color yellow $ circleSolid 13 + renderTwo = Translate (-235) (-370) $ Color yellow $ circleSolid 13 + renderThree = Translate (-200) (-370) $ Color yellow $ circleSolid 13 + + +displayWindow :: Display +displayWindow = InWindow "Pac-Man" (800, 800) (350, 350) + + +renderVictory :: Picture +renderVictory = + Translate (-250) 0 $ + Scale 0.3 0.3 $ + Color white $ + Text "Congratulations! You Win!" + + +renderDefeat :: Picture +renderDefeat = + Translate (-170) 0 $ Scale 0.4 0.4 $ Color white $ Text "Game Over" + + +render :: PacGame -> Picture +render game = case game.gameStatus of + WON -> renderVictory + LOST -> renderDefeat + PLAYING -> + Pictures + [ renderLives game + , renderPowerPellets game + , renderW coords + , renderPacman game + , renderStuff game + , renderPellets game + , renderPinky game + , renderInky game + , renderBlinky game + , renderClyde game + ] + + +main :: IO () +main = do + play displayWindow black fps initialize render handleKeys step + where + step :: Float -> PacGame -> PacGame + step sec game = + sMove sec $ + releaseInky $ + releasePinky $ + releaseClyde $ + moveToTargetC $ + moveToTargetI $ + moveToTargetP $ + moveToTargetB $ + ghostModeSwitch $ + beginTimer $ + ghostCollisionSwitch $ + pacScore $ + pacEat $ + pacEatP $ + wallCollision $ + execM $ + checkTeleport game + + +sMove :: Float -> PacGame -> PacGame +sMove sec game = + game + { pacman = + Characters + { cName = Pacman + , location = (x + vx * sec, y + vy * sec) + , speed = (vx, vy) + } + , blinky = game.blinky{gLocation = (bx + bvx * sec, by + bvy * sec)} + , pinky = game.pinky{gLocation = (px + pvx * sec, py + pvy * sec)} + , inky = game.inky{gLocation = (ix + ivx * sec, iy + ivy * sec)} + , clyde = game.clyde{gLocation = (cx + cvx * sec, cy + cvy * sec)} + } + where + (x, y) = game.pacman.location + (vx, vy) = game.pacman.speed + (bx, by) = game.blinky.gLocation + (bvx, bvy) = game.blinky.gSpeed + (px, py) = game.pinky.gLocation + (pvx, pvy) = game.pinky.gSpeed + (ix, iy) = game.inky.gLocation + (ivx, ivy) = game.inky.gSpeed + (cx, cy) = game.clyde.gLocation + (cvx, cvy) = game.clyde.gSpeed + + +execM :: PacGame -> PacGame +execM game + | curTime <= 2.5 = game + | game.direction == game.bufDirection = game + | game.direction /= game.bufDirection = newgame + | otherwise = game + where + curTime = game.time + newgame + | (vx, vy) == (0, 0) = case game.bufDirection of + UP -> up + DOWN -> down + LEFT -> left + RIGHT -> right + STOP -> stop + | (vx, vy) /= (0, 0) = case game.bufDirection of + UP -> tUP + DOWN -> tDOWN + LEFT -> tLEFT + RIGHT -> tRIGHT + STOP -> tSTOP + | otherwise = game + where + (x, y) = game.pacman.location + (vx, vy) = game.pacman.speed + up = + game + { direction = UP + , pacman = Characters{cName = Pacman, speed = (0, 4), location = (x, y)} + } + down = + game + { direction = DOWN + , pacman = Characters{cName = Pacman, speed = (0, -4), location = (x, y)} + } + left = + game + { direction = LEFT + , pacman = Characters{cName = Pacman, speed = (-4, 0), location = (x, y)} + } + right = + game + { direction = RIGHT + , pacman = Characters{cName = Pacman, speed = (4, 0), location = (x, y)} + } + stop = + game + { direction = STOP + , pacman = Characters{cName = Pacman, speed = (0, 0), location = (x, y)} + } + x' = roundF x + y' = roundF y + tUP = + if elem (x', y' + 1) coords + then game + else + game + { direction = UP + , pacman = Characters{cName = Pacman, speed = (0, 4), location = (x', y')} + } + tDOWN = + if elem (x', y' - 1) coords + then game + else + game + { direction = DOWN + , pacman = Characters{cName = Pacman, speed = (0, -4), location = (x', y')} + } + tLEFT = + if elem (x' - 1, y') coords + then game + else + game + { direction = LEFT + , pacman = Characters{cName = Pacman, speed = (-4, 0), location = (x', y')} + } + tRIGHT = + if elem (x' + 1, y') coords + then game + else + game + { direction = RIGHT + , pacman = Characters{cName = Pacman, speed = (4, 0), location = (x', y')} + } + tSTOP = game + + +wallCollision :: PacGame -> PacGame +wallCollision game = case game.direction of + UP -> up + DOWN -> down + LEFT -> left + RIGHT -> right + STOP -> stop + where + (x, y) = game.pacman.location + x' = roundF x + y' = roundF y + nearGrid = abs (x - x') <= 0.1 && abs (y - y') <= 0.1 + stopped = + game + { direction = STOP + , pacman = Characters{cName = Pacman, speed = (0, 0), location = (x', y')} + } + up = if nearGrid && elem (x', y' + 1) coords then stopped else game + down = if nearGrid && elem (x', y' - 1) coords then stopped else game + left = if nearGrid && elem (x' - 1, y') coords then stopped else game + right = if nearGrid && elem (x' + 1, y') coords then stopped else game + stop = stopped + + +pacEat :: PacGame -> PacGame +pacEat game + | (x', y') `elem` pelletsL = + game{pellets = [p | p <- curPellets, p /= (x', y')]} + | otherwise = game + where + (x, y) = game.pacman.location + x' = roundF x + y' = roundF y + curPellets = game.pellets + + +pacEatP :: PacGame -> PacGame +pacEatP game + | (x', y') `elem` pPelletsL = + game + { fTime = 0 + , gMode = FRIGHTENED + , pPellets = [p | p <- curPellets, p /= (x', y')] + } + | otherwise = game + where + (x, y) = game.pacman.location + x' = roundF x + y' = roundF y + curPellets = game.pPellets + pPelletsL = game.pPellets + + +pacScore :: PacGame -> PacGame +pacScore game + | curScore >= 1700 = game{gameStatus = WON} + | otherwise = game{score = newscore} + where + newscore = + (listLength pelletsL - listLength curPellets) * 10 + + (listLength powerPellet - listLength curPowerPellets) * 50 + curPellets = game.pellets + curScore = game.score + curPowerPellets = game.pPellets + + +checkTeleport :: PacGame -> PacGame +checkTeleport game + | (x', y') == (-10, 0) = + game{pacman = Characters{cName = Pacman, speed = curSpeed, location = (9, 0)}} + | (x', y') == (10, 0) = + game{pacman = Characters{cName = Pacman, speed = curSpeed, location = (-9, 0)}} + | otherwise = game + where + (x, y) = game.pacman.location + x' = roundF x + y' = roundF y + curSpeed = game.pacman.speed diff --git a/picture/PacMan/Maze.hs b/picture/PacMan/Maze.hs new file mode 100644 --- /dev/null +++ b/picture/PacMan/Maze.hs @@ -0,0 +1,441 @@ +module Maze where + +import Brillo + + +coords :: [Point] +coords = + [ (0, 1) + , (-9, -11) + , (-9, -10) + , (-9, -9) + , (-9, -8) + , (-9, -7) + , (-9, -6) + , (-9, -5) + , (-9, -4) + , (-9, -3) + , (-9, -1) + , (-9, 1) + , (-9, 3) + , (-9, 4) + , (-9, 5) + , (-9, 6) + , (-9, 7) + , (-9, 8) + , (-9, 9) + , (9, -10) + , (9, -9) + , (9, -8) + , (9, -7) + , (9, -6) + , (9, -5) + , (9, -4) + , (9, -3) + , (9, -1) + , (9, 1) + , (9, 3) + , (9, 4) + , (9, 5) + , (9, 6) + , (9, 7) + , (9, 8) + , (9, 9) + , (-9, -11) + , (-8, -11) + , (-7, -11) + , (-6, -11) + , (-5, -11) + , (-4, -11) + , (-3, -11) + , (-2, -11) + , (-1, -11) + , (0, -11) + , (1, -11) + , (2, -11) + , (3, -11) + , (4, -11) + , (5, -11) + , (6, -11) + , (7, -11) + , (8, -11) + , (9, -11) + , (-9, 9) + , (-8, 9) + , (-7, 9) + , (-6, 9) + , (-5, 9) + , (-4, 9) + , (-3, 9) + , (-2, 9) + , (-1, 9) + , (0, 9) + , (1, 9) + , (2, 9) + , (3, 9) + , (4, 9) + , (5, 9) + , (6, 9) + , (7, 9) + , (8, 9) + , (9, 9) + , (-2, 0) + , (2, 0) + , (1, 1) + , (-1, 1) + , (2, 1) + , (-2, 1) + , (-2, -1) + , (-1, -1) + , (0, -1) + , (1, -1) + , (2, -1) + , (0, 3) + , (0, 4) + , (0, 5) + , (0, 7) + , (0, 8) + , (0, -3) + , (0, -4) + , (0, -5) + , (0, -7) + , (0, -8) + , (0, -9) + , (1, 5) + , (1, -3) + , (1, -7) + , (2, 3) + , (2, 5) + , (2, 7) + , (2, -3) + , (2, -5) + , (2, -7) + , (2, -9) + , (3, 3) + , (3, 7) + , (3, -5) + , (3, -9) + , (4, 1) + , (4, 2) + , (4, 3) + , (4, 4) + , (4, 5) + , (4, 7) + , (4, -1) + , (4, -2) + , (4, -3) + , (4, -5) + , (4, -7) + , (4, -8) + , (4, -9) + , (5, -9) + , (6, 1) + , (6, 2) + , (6, 3) + , (6, 5) + , (6, 7) + , (6, -1) + , (6, -2) + , (6, -3) + , (6, -5) + , (6, -6) + , (6, -7) + , (6, -9) + , (7, 1) + , (7, 3) + , (7, 5) + , (7, 7) + , (7, -1) + , (7, -3) + , (7, -5) + , (7, -9) + , (8, 1) + , (8, 3) + , (8, -1) + , (8, -3) + , (8, -7) + , (10, 1) + , (10, -1) + , (2, 0) + , (-2, 0) + , (-1, 1) + , (1, 1) + , (-2, 1) + , (2, 1) + , (2, -1) + , (1, -1) + , (0, -1) + , (-1, -1) + , (-2, -1) + , (0, 3) + , (0, 4) + , (0, 5) + , (0, 7) + , (0, 8) + , (0, -3) + , (0, -4) + , (0, -5) + , (0, -7) + , (0, -8) + , (0, -9) + , (-1, 5) + , (-1, -3) + , (-1, -7) + , (-2, 3) + , (-2, 5) + , (-2, 7) + , (-2, -3) + , (-2, -5) + , (-2, -7) + , (-2, -9) + , (-3, 3) + , (-3, 7) + , (-3, -5) + , (-3, -9) + , (-4, 1) + , (-4, 2) + , (-4, 3) + , (-4, 4) + , (-4, 5) + , (-4, 7) + , (-4, -1) + , (-4, -2) + , (-4, -3) + , (-4, -5) + , (-4, -7) + , (-4, -8) + , (-4, -9) + , (-5, -9) + , (-6, 1) + , (-6, 2) + , (-6, 3) + , (-6, 5) + , (-6, 7) + , (-6, -1) + , (-6, -2) + , (-6, -3) + , (-6, -5) + , (-6, -6) + , (-6, -7) + , (-6, -9) + , (-7, 1) + , (-7, 3) + , (-7, 5) + , (-7, 7) + , (-7, -1) + , (-7, -3) + , (-7, -5) + , (-7, -9) + , (-8, 1) + , (-8, 3) + , (-8, -1) + , (-8, -3) + , (-8, -7) + , (-10, 1) + , (-10, -1) + ] + + +pelletsL :: [Point] +pelletsL = + [ (-8, -10) + , (-7, -10) + , (-6, -10) + , (-5, -10) + , (-4, -10) + , (-3, -10) + , (-2, -10) + , (-1, -10) + , (-5, -8) + , (-5, -7) + , (-5, -6) + , (-5, -5) + , (-5, -4) + , (-5, -3) + , (-5, -2) + , (-5, -1) + , (-5, 0) + , (-5, 1) + , (-5, 2) + , (-5, 3) + , (-5, 4) + , (-5, 5) + , (-5, 6) + , (-5, 7) + , (-5, 8) + , (-8, -9) + , (-8, -8) + , (-7, -8) + , (-6, -8) + , (-7, -7) + , (-7, -6) + , (-8, -5) + , (-8, -4) + , (-1, -4) + , (-2, -4) + , (-3, -4) + , (-4, -4) + , (-6, -4) + , (-7, -4) + , (-8, -4) + , (-1, -5) + , (-5, -6) + , (-1, -6) + , (-2, -6) + , (-3, -6) + , (-4, -6) + , (-3, -7) + , (-3, -8) + , (-1, -8) + , (-2, -8) + , (-1, -9) + , (-1, 4) + , (-1, 6) + , (-1, 7) + , (-1, 8) + , (-2, 4) + , (-2, 6) + , (-2, 8) + , (-3, 4) + , (-3, 5) + , (-3, 6) + , (-3, 8) + , (-4, 6) + , (-4, 8) + , (-6, 4) + , (-6, 6) + , (-6, 8) + , (-7, 4) + , (-7, 6) + , (-7, 8) + , (-8, 4) + , (-8, 5) + , (-8, 6) + , (-8, 8) + , (8, -10) + , (7, -10) + , (6, -10) + , (5, -10) + , (4, -10) + , (3, -10) + , (2, -10) + , (1, -10) + , (5, -8) + , (5, -7) + , (5, -6) + , (5, -5) + , (5, -4) + , (5, -3) + , (5, -2) + , (5, -1) + , (5, 0) + , (5, 1) + , (5, 2) + , (5, 3) + , (5, 4) + , (5, 5) + , (5, 6) + , (5, 7) + , (5, 8) + , (8, -9) + , (8, -8) + , (7, -8) + , (6, -8) + , (7, -7) + , (7, -6) + , (8, -5) + , (8, -4) + , (1, -4) + , (2, -4) + , (3, -4) + , (4, -4) + , (6, -4) + , (7, -4) + , (8, -4) + , (1, -5) + , (5, -6) + , (1, -6) + , (2, -6) + , (3, -6) + , (4, -6) + , (3, -7) + , (3, -8) + , (1, -8) + , (2, -8) + , (1, -9) + , (1, 4) + , (1, 6) + , (1, 7) + , (1, 8) + , (2, 4) + , (2, 6) + , (2, 8) + , (3, 4) + , (3, 5) + , (3, 6) + , (3, 8) + , (4, 6) + , (4, 8) + , (6, 4) + , (6, 6) + , (6, 8) + , (7, 4) + , (7, 6) + , (7, 8) + , (8, 4) + , (8, 5) + , (8, 6) + , (8, 8) + , (0, -10) + , (0, 6) + ] + + +powerPellet :: [Point] +powerPellet = [(-8, -6), (8, -6), (-8, 7), (8, 7)] + + +crossR :: [Point] +crossR = + [ (1, 2) + , (1, 6) + , (3, 6) + , (5, 6) + , (8, 6) + , (5, 8) + , (8, 6) + , (3, -4) + , (5, -4) + , (1, -6) + , (3, -6) + , (5, -6) + , (7, -8) + , (1, -10) + , (-1, 2) + , (-1, 6) + , (-3, 6) + , (-5, 6) + , (-8, 6) + , (-5, 8) + , (-8, 6) + , (-3, -4) + , (-5, -4) + , (-1, -6) + , (-3, -6) + , (-5, -6) + , (-7, -8) + , (-1, -10) + , (-5, 4) + , (5, 4) + ] + + +renderS :: Point -> Picture +renderS (x, y) = + Translate (x * 30) (y * 30) wallBlock + where + wallBlock = Color (dark blue) $ rectangleSolid 30 30 + + +renderW :: [Point] -> Picture +renderW walls = Pictures [renderS w | w <- walls] diff --git a/picture/PacMan/Structs.hs b/picture/PacMan/Structs.hs new file mode 100644 --- /dev/null +++ b/picture/PacMan/Structs.hs @@ -0,0 +1,87 @@ +module Structs where + +import Brillo (Point) + + +type Velocity = (Float, Float) + + +fps :: Int +fps = 60 + + +frightenLength :: Float +frightenLength = 4.0 + + +data Name = Pacman | Pinky | Inky | Blinky | Clyde + deriving (Eq) + + +data Direction = UP | DOWN | LEFT | RIGHT | STOP + deriving (Eq, Show, Ord, Enum, Bounded) + + +data GameStatus = WON | LOST | PLAYING + deriving (Eq, Show) + + +data Mode = SCATTER | CHASE | FRIGHTENED + deriving (Eq, Show) + + +blinkyScatterTarget :: Point +blinkyScatterTarget = (8, 10) + + +inkyScatterTarget :: Point +inkyScatterTarget = (8, -12) + + +pinkyScatterTarget :: Point +pinkyScatterTarget = (-8, 10) + + +clydeScatterTarget :: Point +clydeScatterTarget = (-8, -12) + + +data Characters = Characters + { cName :: Name + , speed :: Velocity + , location :: Point + } + deriving (Eq) + + +data Ghost = Ghost + { gName :: Name + , gSpeed :: Velocity + , gLocation :: Point + , gTarget :: Point + , gLastMove :: Direction + , gDirection :: Direction + } + + +data PacGame = Game + { lives :: Int + , gameStatus :: GameStatus + , pacman :: Characters + , pinky :: Ghost + , inky :: Ghost + , blinky :: Ghost + , clyde :: Ghost + , time :: Float + , score :: Int + , pellets :: [Point] + , direction :: Direction + , bufDirection :: Direction + , gMode :: Mode + , lcrB :: Point + , lcrP :: Point + , lcrI :: Point + , lcrC :: Point + , pPellets :: [Point] + , fTime :: Float + } diff --git a/picture/PickFiles/Main.hs b/picture/PickFiles/Main.hs new file mode 100644 --- /dev/null +++ b/picture/PickFiles/Main.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Brillo.Data.Color (white) +import Brillo.Data.Display (Display (InWindow)) +import Brillo.Data.FileDialog ( + FileDialog (..), + SelectionMode (..), + ) +import Brillo.Data.Picture (Picture (Pictures, Scale, ThickText, Translate)) +import Brillo.Interface.Environment (openFileDialog) +import Brillo.Interface.IO.Game ( + Event (EventKey), + Key (MouseButton), + KeyState (Down), + MouseButton (LeftButton, RightButton), + playIO, + ) +import Data.Function ((&)) +import Data.Functor ((<&>)) +import Data.Text (Text) +import Data.Text qualified as T + + +size :: (Num width, Num height) => (width, height) +size = (600, 600) + + +data State + = NotAsked + | Success [FilePath] + | Failure Text + + +moveToTopLeftWithOffset :: Float -> Picture -> Picture +moveToTopLeftWithOffset offset = do + let + w = fst (size :: (Float, Float)) + h = snd (size :: (Float, Float)) + Translate (-(w / 2) + offset) (h / 2 - offset) + + +makePicture :: State -> IO Picture +makePicture state = + case state of + NotAsked -> + pure $ + Pictures + [ moveToTopLeftWithOffset 50 $ + Scale 0.2 0.2 $ + ThickText "Left-click anywhere to pick files or" 3 + , moveToTopLeftWithOffset 100 $ + Scale 0.2 0.2 $ + ThickText "right-click to pick a directory" 3 + ] + Failure errorMessage -> + pure $ + Pictures + [ moveToTopLeftWithOffset 30 $ + Scale 0.1 0.1 $ + ThickText errorMessage 2 + ] + Success filePaths -> + pure $ + Pictures $ + filePaths & zip [(1 :: Int) ..] <&> \(i, filePath) -> + moveToTopLeftWithOffset 0 $ + Translate 10 (fromIntegral (-(25 * i))) $ + Scale 0.1 0.1 $ + ThickText (T.pack filePath) 2 + + +handleEvent :: Event -> State -> IO State +handleEvent event state = + case event of + EventKey (MouseButton mouseButton) Down _modifiers _point -> do + filePathsMb <- + openFileDialog $ + FileDialog + { title = "Pick Files" + , defaultPath = "." + , filterPatterns = [] + , filterDescription = "All files" + , selectionMode = case mouseButton of + LeftButton -> MultiFileSelect + RightButton -> SingleDirectorySelect + _ -> MultiFileSelect + } + case filePathsMb of + Just filePaths -> return $ Success filePaths + Nothing -> return $ Failure "No files were picked" + _ -> return state + + +stepWorld :: Float -> State -> IO State +stepWorld _ = return + + +main :: IO () +main = do + let state = NotAsked + playIO + (InWindow "PickFiles" size (0, 0)) + white + 100 + state + makePicture + handleEvent + stepWorld diff --git a/picture/Polygons/Main.hs b/picture/Polygons/Main.hs new file mode 100644 --- /dev/null +++ b/picture/Polygons/Main.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE OverloadedStrings #-} + +{-| Example demonstrating polygon rendering, including both convex and +non-convex (complex) polygons. Brillo automatically handles non-convex +polygons using GLU tessellation. +-} +module Main where + +import Brillo + + +main :: IO () +main = + display + (InWindow "Polygons" (800, 600) (10, 10)) + white + picture + + +picture :: Picture +picture = + Pictures + [ -- Row 1: Convex polygons (fast path) + Translate (-300) 200 $ Color red convexTriangle + , Translate (-100) 200 $ Color green convexSquare + , Translate 100 200 $ Color blue convexPentagon + , Translate 300 200 $ Color orange convexHexagon + , -- Row 2: Non-convex polygons (tessellation path) + Translate (-300) 0 $ Color violet starShape + , Translate (-100) 0 $ Color cyan arrowShape + , Translate 100 0 $ Color magenta lShape + , Translate 300 0 $ Color rose crossShape + , -- Row 3: More complex non-convex shapes + Translate (-200) (-200) $ Color azure hourglassShape + , Translate 0 (-200) $ Color chartreuse zigzagShape + , Translate 200 (-200) $ Color aquamarine pacmanShape + ] + + +-- Convex polygons (rendered using fast GL.Polygon path) + +convexTriangle :: Picture +convexTriangle = + Polygon + [ (0, 50) + , (-43, -25) + , (43, -25) + ] + + +convexSquare :: Picture +convexSquare = + Polygon + [ (-40, -40) + , (40, -40) + , (40, 40) + , (-40, 40) + ] + + +convexPentagon :: Picture +convexPentagon = + Polygon + [ (0, 50) + , (-48, 15) + , (-30, -40) + , (30, -40) + , (48, 15) + ] + + +convexHexagon :: Picture +convexHexagon = + Polygon + [ (0, 50) + , (-43, 25) + , (-43, -25) + , (0, -50) + , (43, -25) + , (43, 25) + ] + + +-- Non-convex polygons (rendered using GLU tessellation) + +starShape :: Picture +starShape = + Polygon + [ (0, 60) + , (-15, 20) + , (-55, 20) + , (-25, -10) + , (-35, -50) + , (0, -25) + , (35, -50) + , (25, -10) + , (55, 20) + , (15, 20) + ] + + +arrowShape :: Picture +arrowShape = + Polygon + [ (0, 50) + , (-40, 0) + , (-20, 0) + , (-20, -50) + , (20, -50) + , (20, 0) + , (40, 0) + ] + + +lShape :: Picture +lShape = + Polygon + [ (-30, 50) + , (-30, -50) + , (30, -50) + , (30, -20) + , (0, -20) + , (0, 50) + ] + + +crossShape :: Picture +crossShape = + Polygon + [ (-15, 50) + , (-15, 15) + , (-50, 15) + , (-50, -15) + , (-15, -15) + , (-15, -50) + , (15, -50) + , (15, -15) + , (50, -15) + , (50, 15) + , (15, 15) + , (15, 50) + ] + + +hourglassShape :: Picture +hourglassShape = + Polygon + [ (-40, 50) + , (40, 50) + , (0, 0) + , (40, -50) + , (-40, -50) + , (0, 0) + ] + + +zigzagShape :: Picture +zigzagShape = + Polygon + [ (-50, 30) + , (-25, 30) + , (-25, -30) + , (0, -30) + , (0, 30) + , (25, 30) + , (25, -30) + , (50, -30) + , (50, -50) + , (-50, -50) + ] + + +pacmanShape :: Picture +pacmanShape = + let + radius = 50 :: Float + segments = 20 :: Int + mouthAngle = pi / 4 + angles = + [mouthAngle, mouthAngle + step .. 2 * pi - mouthAngle] + ++ [2 * pi - mouthAngle] + step = (2 * pi - 2 * mouthAngle) / fromIntegral segments + in + Polygon $ + (0, 0) : [(radius * cos a, radius * sin a) | a <- angles] diff --git a/picture/Snake/Main.hs b/picture/Snake/Main.hs new file mode 100644 --- /dev/null +++ b/picture/Snake/Main.hs @@ -0,0 +1,227 @@ +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} + +module Main (main) where + +import Brillo +import Brillo.Interface.Pure.Game +import Data.Text qualified as T +import System.Random (StdGen, getStdGen, randomR) + + +cols :: Int +cols = 32 + + +rows :: Int +rows = 24 + + +cellSize :: Float +cellSize = 20 + + +data Direction = DirUp | DirDown | DirLeft | DirRight + deriving (Eq) + + +type Cell = (Int, Int) + + +data Phase = WaitingToStart | Playing | Dead + deriving (Eq) + + +data GameState = GameState + { snake :: [Cell] + , food :: Cell + , direction :: Direction + , phase :: Phase + , randomGen :: StdGen + , score :: Int + } + + +dirVector :: Direction -> Cell +dirVector DirUp = (0, -1) +dirVector DirDown = (0, 1) +dirVector DirLeft = (-1, 0) +dirVector DirRight = (1, 0) + + +opposite :: Direction -> Direction +opposite DirUp = DirDown +opposite DirDown = DirUp +opposite DirLeft = DirRight +opposite DirRight = DirLeft + + +moveSnake :: Cell -> Direction -> [Cell] -> (Bool, [Cell]) +moveSnake _ _ [] = (False, []) +moveSnake foodCell dir snk@((hx, hy) : _) = + let (dx, dy) = dirVector dir + newHead = (hx + dx, hy + dy) + in if newHead == foodCell + then (True, newHead : snk) + else (False, newHead : init snk) + + +isDead :: [Cell] -> Bool +isDead [] = True +isDead ((hx, hy) : t) = + hx <= 0 || hx >= cols || hy <= 0 || hy >= rows || (hx, hy) `elem` t + + +generateFood :: [Cell] -> StdGen -> (Cell, StdGen) +generateFood snk gen + | newFood `elem` snk = generateFood snk gen3 + | otherwise = (newFood, gen3) + where + (fx, gen2) = randomR (1, cols - 1) gen + (fy, gen3) = randomR (1, rows - 1) gen2 + newFood = (fx, fy) + + +-- Keep the head at least 5 cells from any wall so the initial +-- snake body fits and there's room to move before hitting a wall. +initialState :: Phase -> StdGen -> GameState +initialState p gen0 = + let margin = 5 + (hx, gen1) = randomR (margin, cols - margin) gen0 + (hy, gen2) = randomR (margin, rows - margin) gen1 + (dirIdx, gen3) = randomR (0 :: Int, 3) gen2 + dir = [DirUp, DirDown, DirLeft, DirRight] !! dirIdx + (dx, dy) = dirVector (opposite dir) + body = [(hx + dx * i, hy + dy * i) | i <- [0 .. 4]] + (foodCell, gen4) = generateFood body gen3 + in GameState + { snake = body + , food = foodCell + , direction = dir + , phase = p + , randomGen = gen4 + , score = 0 + } + + +-- Rendering + +render :: GameState -> Picture +render gs = + Pictures $ + concat + [ walls + , drawSnake gs.snake + , [drawCell red gs.food] + , [scoreText] + , overlay + ] + where + toScreen :: Cell -> (Float, Float) + toScreen (x, y) = + ( fromIntegral x * cellSize - 320 + , fromIntegral y * cellSize - 240 + ) + + drawCell :: Color -> Cell -> Picture + drawCell clr cell = + let (sx, sy) = toScreen cell + in Color clr $ + Scale 1 (-1) $ + Translate sx sy $ + rectangleSolid cellSize cellSize + + drawSnake :: [Cell] -> [Picture] + drawSnake [] = [] + drawSnake (h : t) = drawCell green h : map (drawCell (dark green)) t + + wallRect :: (Float, Float) -> (Float, Float) -> Picture + wallRect (tx, ty) (w, h) = + Color (greyN 0.4) $ + Scale 1 (-1) $ + Translate (tx * cellSize - 320) (ty * cellSize - 240) $ + rectangleSolid w h + + walls = + [ wallRect (16, 0) (640, cellSize) + , wallRect (16, 24) (640, cellSize) + , wallRect (0, 12) (cellSize, 480) + , wallRect (32, 12) (cellSize, 480) + ] + + scoreText = + Color white $ + Translate (-300) 220 $ + Scale 0.15 0.15 $ + Text $ + T.pack $ + "Score: " ++ show gs.score + + overlay = case phase gs 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." + ] + Playing -> [] + + +-- Input handling + +handleInput :: Event -> GameState -> GameState +handleInput (EventKey (SpecialKey KeyLeft) Down _ _) gs = changeDirection gs DirLeft +handleInput (EventKey (SpecialKey KeyRight) Down _ _) gs = changeDirection gs DirRight +handleInput (EventKey (SpecialKey KeyUp) Down _ _) gs = changeDirection gs DirUp +handleInput (EventKey (SpecialKey KeyDown) Down _ _) gs = changeDirection gs DirDown +handleInput (EventKey (SpecialKey KeySpace) Down _ _) gs = case phase gs of + WaitingToStart -> gs{phase = Playing} + Dead -> initialState Playing gs.randomGen + Playing -> gs +handleInput _ gs = gs + + +changeDirection :: GameState -> Direction -> GameState +changeDirection gs newDir + | newDir == opposite gs.direction = gs + | otherwise = gs{direction = newDir} + + +-- Update + +update :: Float -> GameState -> GameState +update _ gs + | phase gs /= Playing = gs + | otherwise = + let (ate, newSnake) = moveSnake gs.food gs.direction gs.snake + (newFood, newGen) = generateFood newSnake gs.randomGen + in gs + { snake = newSnake + , food = if ate then newFood else gs.food + , phase = if isDead newSnake then Dead else Playing + , randomGen = if ate then newGen else gs.randomGen + , score = if ate then gs.score + 1 else gs.score + } + + +main :: IO () +main = do + gen <- getStdGen + play + (InWindow "Snake" (640, 480) (100, 100)) + black + 10 + (initialState WaitingToStart gen) + render + handleInput + update diff --git a/picture/Styrene/Actor.hs b/picture/Styrene/Actor.hs --- a/picture/Styrene/Actor.hs +++ b/picture/Styrene/Actor.hs @@ -27,23 +27,23 @@ -- | The actors in the world. data Actor = Wall + -- | unique index of this actor !Index - -- ^ unique index of this actor + -- | wall starting point !Position - -- ^ wall starting point + -- | wall ending point !Position - -- ^ wall ending point | Bead + -- | unique index of this actor !Index - -- ^ unique index of this actor + -- | whether the bead is stuck !Int - -- ^ whether the bead is stuck + -- | radius of bead !Radius - -- ^ radius of bead + -- | position of bead !Position - -- ^ position of bead + -- | velocity of bead !Velocity - -- ^ velocity of bead deriving (Show) @@ -90,3 +90,4 @@ actorSetMode :: Int -> Actor -> Actor actorSetMode m (Bead ix _ r p v) = Bead ix m r p v +actorSetMode _ wall@(Wall _ _ _) = wall diff --git a/picture/Styrene/Advance.hs b/picture/Styrene/Advance.hs --- a/picture/Styrene/Advance.hs +++ b/picture/Styrene/Advance.hs @@ -22,15 +22,15 @@ -- Advance --------------------------------------------------------------------- -- | Advance all the actors in this world by a certain time. -advanceWorld - :: ViewPort - -- ^ current viewport - -> Time - -- ^ time to advance them for. - -> World - -- ^ the world to advance. - -> World - -- ^ the new world. +advanceWorld :: + -- | current viewport + ViewPort -> + -- | time to advance them for. + Time -> + -- | the world to advance. + World -> + -- | the new world. + World advanceWorld viewport time (World actors tree) = let rot = viewPortRotate viewport @@ -54,66 +54,66 @@ -- Move two actors which are known to be in contact. -applyContact - :: Time - -- ^ time step - -> Force - -- ^ ambient force on the actors - -> (Index, Index) - -- ^ indicies of the the two actors in contact - -> Map Index Actor - -- ^ the old world - -> Map Index Actor - -- ^ the new world -applyContact time force (ix1, ix2) actors = - let - -- use the indicies to lookup the data for each actor from the map - Just a1 = Map.lookup ix1 actors - Just a2 = Map.lookup ix2 actors - - resultActors - -- handle a collision between bead and a wall - | Bead _ _ r1 p1 v1 <- a1 - , Wall{} <- a2 = - let a1' = collideBeadWall a1 a2 - in Map.insert ix1 a1' actors - -- handle a collision between two beads - | Bead ix1 m1 r1 p1 v1 <- a1 - , Bead ix2 m2 r2 p2 v2 <- a2 = - let - (a1', a2') - -- if one of the beads is stuck then do a safer, static collision. - -- with this method the beads don't transfer energy into each other - -- so there is less of a chance of lots of beads being crushed - -- together if there are many in the same place. - | m1 >= beadStuckCount || m2 >= beadStuckCount = - let a1' = collideBeadBeadStatic a1 a2 - a2' = collideBeadBeadStatic a2 a1 - in (a1', a2') - -- otherwise do the real elastic collision - -- this is much more realistic. - | otherwise = - collideBeadBeadElastic a1 a2 - in - -- write the new data for the actors back into the map - Map.insert ix1 a1' $ - Map.insert ix2 a2' actors - | otherwise = - actors - in - resultActors +applyContact :: + -- | time step + Time -> + -- | ambient force on the actors + Force -> + -- | indicies of the the two actors in contact + (Index, Index) -> + -- | the old world + Map Index Actor -> + -- | the new world + Map Index Actor +applyContact _time _force (ix1, ix2) actors = + -- use the indicies to lookup the data for each actor from the map + case (Map.lookup ix1 actors, Map.lookup ix2 actors) of + (Just a1, Just a2) -> + let + resultActors + -- handle a collision between bead and a wall + | Bead _ _ _r1 _p1 _v1 <- a1 + , Wall{} <- a2 = + let a1' = collideBeadWall a1 a2 + in Map.insert ix1 a1' actors + -- handle a collision between two beads + | Bead _ix1 m1 _r1 _p1 _v1 <- a1 + , Bead _ix2 m2 _r2 _p2 _v2 <- a2 = + let + (a1', a2') + -- if one of the beads is stuck then do a safer, static collision. + -- with this method the beads don't transfer energy into each other + -- so there is less of a chance of lots of beads being crushed + -- together if there are many in the same place. + | m1 >= beadStuckCount || m2 >= beadStuckCount = + let a1'' = collideBeadBeadStatic a1 a2 + a2'' = collideBeadBeadStatic a2 a1 + in (a1'', a2'') + -- otherwise do the real elastic collision + -- this is much more realistic. + | otherwise = + collideBeadBeadElastic a1 a2 + in + -- write the new data for the actors back into the map + Map.insert ix1 a1' $ + Map.insert ix2 a2' actors + | otherwise = + actors + in + resultActors + _ -> actors -- | Move a bead which isn't in contact with anything else. -moveActorFree - :: Time - -- ^ time to move it for - -> Force - -- ^ ambient force on the actor during this time - -> Actor - -- ^ the bead to move - -> Actor - -- ^ the new bead +moveActorFree :: + -- | time to move it for + Time -> + -- | ambient force on the actor during this time + Force -> + -- | the bead to move + Actor -> + -- | the new bead + Actor moveActorFree time force actor -- move a bead | Bead ix stuck radius pos vel <- actor = diff --git a/picture/Styrene/Collide.hs b/picture/Styrene/Collide.hs --- a/picture/Styrene/Collide.hs +++ b/picture/Styrene/Collide.hs @@ -28,13 +28,13 @@ -- | Move a bead which is in contact with a wall. -collideBeadWall - :: Actor - -- ^ the bead - -> Actor - -- ^ the wall that bead is in contact with - -> Actor - -- ^ the new bead +collideBeadWall :: + -- | the bead + Actor -> + -- | the wall that bead is in contact with + Actor -> + -- | the new bead + Actor collideBeadWall bead@(Bead _ix _ _radius pBead _vIn) (Wall _ pWall1 pWall2) = @@ -52,10 +52,10 @@ -- | Move two beads which have bounced into each other. -collideBeadBeadElastic - :: Actor - -> Actor - -> (Actor, Actor) +collideBeadBeadElastic :: + Actor -> + Actor -> + (Actor, Actor) collideBeadBeadElastic (Bead ix1 mode1 r1 p1 v1) (Bead ix2 mode2 r2 p2 v2) = @@ -102,10 +102,10 @@ collideBeadBeadElastic _ _ = error "collideBeadBeadElastic: not two beads" -collideBeadBeadStatic - :: Actor - -> Actor - -> Actor +collideBeadBeadStatic :: + Actor -> + Actor -> + Actor collideBeadBeadStatic bead1@(Bead _ix1 _ radius1 pBead1 _) (Bead _ix2 _ radius2 pBead2 _) = @@ -127,14 +127,14 @@ -- | Move a bead which has collided with something. -collideBeadPointStatic - :: Actor - -- ^ the bead which collided with something - -> Point - -- ^ the point of collision (should be near the bead's surface) - -> Float - -- ^ velocity scaling factor (how much to slow the bead down after the collision) - -> Actor +collideBeadPointStatic :: + -- | the bead which collided with something + Actor -> + -- | the point of collision (should be near the bead's surface) + Point -> + -- | velocity scaling factor (how much to slow the bead down after the collision) + Float -> + Actor collideBeadPointStatic (Bead ix mode radius pBead vIn) pCollision diff --git a/picture/Styrene/Contact.hs b/picture/Styrene/Contact.hs --- a/picture/Styrene/Contact.hs +++ b/picture/Styrene/Contact.hs @@ -32,13 +32,13 @@ -- Find all pairs of actors in the world that are in contact with each other. -findContacts - :: World - -> ( -- a set of all pairs of actors that are in contact. - Set (Index, Index) - , -- also return the quadtree so we can draw it in the window. - QuadTree Actor - ) +findContacts :: + World -> + ( -- a set of all pairs of actors that are in contact. + Set (Index, Index) + , -- also return the quadtree so we can draw it in the window. + QuadTree Actor + ) findContacts (World actors _) = let -- the initial tree has no actors in it and has a diff --git a/picture/Styrene/Main.hs b/picture/Styrene/Main.hs --- a/picture/Styrene/Main.hs +++ b/picture/Styrene/Main.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + module Main where import Actor (Actor (..)) diff --git a/picture/Styrene/QuadTree.hs b/picture/Styrene/QuadTree.hs --- a/picture/Styrene/QuadTree.hs +++ b/picture/Styrene/QuadTree.hs @@ -44,20 +44,20 @@ -- Quadrant -------------------------------------------------------------------- -- | Insert an element with a bounding box into the tree -treeInsert - :: Int - -- ^ maximum depth to place a leaf - -> Int - -- ^ current depth - -> Point - -- ^ bottom left of bounding box of new element - -> Point - -- ^ top right of bounding box of new element - -> a - -- ^ element to insert into tree - -> QuadTree a - -- ^ current tree - -> QuadTree a +treeInsert :: + -- | maximum depth to place a leaf + Int -> + -- | current depth + Int -> + -- | bottom left of bounding box of new element + Point -> + -- | top right of bounding box of new element + Point -> + -- | element to insert into tree + a -> + -- | current tree + QuadTree a -> + QuadTree a treeInsert depthMax depth p0@(x0, y0) p1@(x1, y1) a tree = case tree of QNode p@(x, y) size tNW tNE tSW tSE -> diff --git a/picture/Tetris/Main.hs b/picture/Tetris/Main.hs new file mode 100644 --- /dev/null +++ b/picture/Tetris/Main.hs @@ -0,0 +1,5 @@ +import Game + + +main :: IO () +main = runGame diff --git a/picture/Tetris/src/Config.hs b/picture/Tetris/src/Config.hs new file mode 100644 --- /dev/null +++ b/picture/Tetris/src/Config.hs @@ -0,0 +1,110 @@ +module Config where + + +-- | Position in blocks in grid +type GridPosition = (Int, Int) + + +-- | Position in pixels on screen +type Position = (Float, Float) + + +-- | Window size in pixels +type WindowSize = (Int, Int) + + +-- Game size in pixels +type GameSize = (Float, Float) + + +-- Cup size in pixels +type CupSize = (Float, Float) + + +-- Window position relates to screen +type WindowPosition = (Int, Int) + + +-- Size of one square block of grid +type BlockSize = Float + + +-- Size of grid in blocks +type GridSize = (Int, Int) + + +data AppConfig = AppConfig + { windowSize :: WindowSize -- Window size in pixels + , gameSize :: GameSize -- Game size in pixels + , cupSize :: CupSize -- Cup size in pixels (computed) + , windowPosition :: WindowPosition -- Window position relates to screen + , gamePosition :: Position -- Game position relates to window (computed?) + , cupPosition :: Position -- Cup position relates to game (computed?) + , blockSize :: BlockSize -- Size of one square block of grid + , gridSize :: GridSize -- Size of grid in blocks + , startPosition :: GridPosition -- Starting position of the falling figures (computed) + , fontPath :: FilePath -- Path to TrueType font file + } + + +-- | Default app config constructor +defaultAppConfig :: FilePath -> AppConfig +defaultAppConfig = + createAppConfig + defaultWindowSize + defaultGameSize + defaultBlockSize + defaultGridSize + defaultWindowPosition + + +-- | Creates AppConfig with computed properties +createAppConfig :: + WindowSize -> + GameSize -> + BlockSize -> + GridSize -> + WindowPosition -> + FilePath -> + AppConfig +createAppConfig ws gms bs grs wp fp = + AppConfig + ws + gms + (cupSize' bs grs) + wp + (gamePosition gms) + (cupPosition' gms) + bs + grs + (startPosition grs) + fp + where + cupSize' :: BlockSize -> GridSize -> CupSize + cupSize' bs' (grw, grh) = (bs' * fromIntegral grw, bs' * fromIntegral grh) + gamePosition (gmw, gmh) = (-gmw / 2, gmh / 2) + cupPosition' _ = (-97, -200) -- let (x,y) = gamePosition gms in + -- (x + gmw * 0.1, y - gmh * 0.1) + startPosition (grw, grh) = (div grw 2, grh + 1) + + +------------------- Default values ------------------ + +defaultWindowSize :: WindowSize +defaultWindowSize = (810, 600) + + +defaultGameSize :: GameSize +defaultGameSize = (500, 500) + + +defaultBlockSize :: BlockSize +defaultBlockSize = 20 + + +defaultGridSize :: GridSize +defaultGridSize = (10, 20) + + +defaultWindowPosition :: WindowPosition +defaultWindowPosition = (20, 20) diff --git a/picture/Tetris/src/Drawing.hs b/picture/Tetris/src/Drawing.hs new file mode 100644 --- /dev/null +++ b/picture/Tetris/src/Drawing.hs @@ -0,0 +1,353 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Drawing (drawWindow, restartButtonBounds) where + +import Config +import Figures +import World + +import Control.Monad.Reader +import Control.Monad.State +import Data.Text (pack) + +import Brillo + + +toGlossColor :: GameColor -> Color +toGlossColor Red = makeColorI 224 102 102 255 +toGlossColor Yellow = makeColorI 245 220 116 255 +toGlossColor Green = makeColorI 180 198 104 255 +toGlossColor Blue = makeColorI 71 176 223 255 +toGlossColor Violet = makeColorI 190 162 222 255 + + +-- CONSTANT COLORS FOR DRAWING FUNCTIONS + +backgroundColor :: Color +backgroundColor = makeColorI 29 31 33 255 + + +textColor :: Color +textColor = makeColorI 197 200 198 255 + + +gridColor :: Color +gridColor = makeColorI 255 255 255 40 + + +cupColor :: Color +cupColor = makeColorI 85 85 85 255 + + +overlayColor :: Color +overlayColor = makeColorI 10 10 10 200 + + +gameOverColor :: Color +gameOverColor = makeColorI 181 7 7 220 + + +restartButtonColor :: Color +restartButtonColor = makeColorI 71 136 183 255 + + +-- | Bounds of the restart button: (x, y, width, height) +restartButtonBounds :: AppConfig -> (Float, Float, Float, Float) +restartButtonBounds conf = + let (px, py) = cupPosition conf + (w, h) = cupSize conf + (cx, cy) = (px + w / 2, py + h / 2) + bw = 120 + bh = 36 + bx = cx - bw / 2 + by = cy - 85 + in (bx, by, bw, bh) + + +-- DRAWING FUNCTIONS + +-- | Draws all help components +drawHelp :: StateT TetrisGame (Reader AppConfig) Picture +drawHelp = do + gameState <- get + conf <- ask + let (x, y) = cupPosition conf + let w = snd $ cupSize conf + let fp = fontPath conf + return $ + Pictures $ + writeInfo fp (x - 250, y + w) (-22) (hardness gameState) (score gameState) + where + writeInfo fp (x, y) step hard scr = + snd $ + foldl + ( \(s, pics) str -> + ( s + step + , pics ++ [Color textColor $ Translate x (y + s) $ TrueTypeText fp 14 str] + ) + ) + (step, []) + [ "Press P to pause" + , "or unpause the game." + , "Press Up Arrow to rotate." + , "Press Space to drop." + , "" + , "Hardness : " <> pack (show hard) + , "Score " <> pack (show scr) + ] + + +-- | Draws a one basic block on the grid +drawBlock :: Block -> Color -> StateT TetrisGame (Reader AppConfig) Picture +drawBlock block blockColor = do + conf <- ask + let cp = cupPosition conf + let sz = blockSize conf + let bxp = fst cp + ((fromIntegral $ fst block) * sz) + let byp = snd cp + ((fromIntegral $ snd block) * sz) + return $ + Color + blockColor + ( Polygon + [ (bxp + 1, byp + 1) + , (bxp + sz - 1, byp + 1) + , (bxp + sz - 1, byp + sz - 1) + , (bxp + 1, byp + sz - 1) + ] + ) + + +-- | Draws falling figure of the game state +drawFigure :: + Color -> GridPosition -> Figure -> StateT TetrisGame (Reader AppConfig) Picture +drawFigure c p f@(Figure _ _ _bs) = + mapM ((flip drawBlock) c) (getRealCoords f p) >>= return . Pictures + + +-- | Draws a figure on the grid +drawGrid :: StateT TetrisGame (Reader AppConfig) Picture +drawGrid = do + gameState <- get + pics <- + mapM (\(p, c) -> p `drawBlock` (toGlossColor c)) (getGridAsList gameState) + return $ Pictures pics + + +-- | Draws a cup figures are falling into (with empty grid) +drawCup :: StateT TetrisGame (Reader AppConfig) Picture +drawCup = do + config <- ask + (x, y) <- fmap cupPosition $ ask + sz <- fmap cupSize $ ask + let height = snd sz + let width = fst sz + return $ + Pictures + [ drawEmptyGrid config + , Color cupColor $ + Line + [ (x, y + height) + , (x, y) + , (x + width, y) + , (x + width, y + height) + ] + ] + + +-- | Draws empty grid +drawEmptyGrid :: AppConfig -> Picture +drawEmptyGrid conf = + let cp = cupPosition conf + in let gsY = snd $ gridSize conf -- Number of cells along vertical axis + in let stepY = (snd $ cupSize conf) / fromIntegral gsY -- step y along vertical axis + in let gsX = fst $ gridSize conf -- Number of cells along horizontal axis + in let stepX = (fst $ cupSize conf) / fromIntegral gsX -- step x along horizontal axis + in Color gridColor $ + Pictures [drawHorizontal cp gsY stepY, drawVertical cp gsX stepX] + where + drawHorizontal cp gsY stepY = + let points = + [ snd cp + stepY * 1 + , snd cp + stepY * 2 + .. snd cp + stepY * (fromIntegral gsY - 1) -- Y line coords along vertical axis + ] + in Pictures $ + zipWith + (\p1 p2 -> Line [(fst cp, p1), (fst cp + (fst $ cupSize conf), p2)]) + points + points + drawVertical cp gsX stepX = + let points = + [ fst cp + stepX * 1 + , fst cp + stepX * 2 + .. fst cp + (stepX * fromIntegral gsX - 1) -- X line coords along horizontal axis + ] + in Pictures $ + zipWith + (\p1 p2 -> Line [(p1, snd cp), (p2, snd cp + (snd $ cupSize conf))]) + points + points + + +-- | Draws right sidebar +drawSidebar :: StateT TetrisGame (Reader AppConfig) Picture +drawSidebar = do + gameState <- get + conf <- ask + let fp = fontPath conf + let fColor = toGlossColor $ case nextColors gameState of + (c : _) -> c + [] -> Red -- Default color if list is empty + pic <- + drawNextFigure + fp + (gridSize conf) + (getNextFigure gameState) + fColor + (blockSize conf) + (cupPosition conf) + return $ Pictures [pic] + where + drawNextFigure fp pos fig fColor bs cp = + let np = (fst pos + 3, snd pos - 4) + in drawFigure fColor ((\(x, y) -> (x + 1, y - 1)) np) fig + >>= return + . Pictures + . ( : + [ Color textColor + $ Translate + (fst cp + (fromIntegral $ fst np) * bs) + (snd cp + (fromIntegral $ (snd np + 3)) * bs) + $ TrueTypeText fp 16 "Next" + ] + ) + + +-- | Draws the left game window +drawGame :: StateT TetrisGame (Reader AppConfig) Picture +drawGame = do + cupPic <- drawCup + (_x, _y) <- fmap gamePosition $ ask + return $ Pictures [cupPic] + + +drawGameOver :: StateT TetrisGame (Reader AppConfig) Picture +drawGameOver = do + conf <- ask + gameState <- get + let (px, py) = cupPosition conf + let (w, h) = cupSize conf + let (_winw, _winh) = windowSize conf + let (winw, winh) = (fromIntegral _winw, fromIntegral _winh) + let (cx, cy) = (px + w / 2, py + h / 2) + let fp = fontPath conf + let overlay = + Color overlayColor $ + Polygon + [ (-winw, -winh) + , (-winw, winh) + , (winw, winh) + , (winw, -winh) + ] + let (bx, by, bw, bh) = restartButtonBounds conf + return $ + Pictures + [ overlay + , Color gameOverColor $ + Translate (cx - 90) (cy + 20) $ + TrueTypeText fp 36 "Game Over" + , let scoreStr = show $ score gameState + scoreWidth = fromIntegral (length scoreStr) * 13 + in Color textColor $ + Translate (cx - scoreWidth / 2) (cy - 25) $ + TrueTypeText fp 24 $ + pack scoreStr + , Color restartButtonColor $ + Polygon + [ (bx, by) + , (bx + bw, by) + , (bx + bw, by + bh) + , (bx, by + bh) + ] + , Color (makeColorI 255 255 255 255) $ + Translate (bx + 30) (by + 10) $ + TrueTypeText fp 18 "Restart" + ] + + +drawPauseOverlay :: StateT TetrisGame (Reader AppConfig) Picture +drawPauseOverlay = do + conf <- ask + _gameState <- get + let (px, py) = cupPosition conf + let (w, h) = cupSize conf + let (_winw, _winh) = windowSize conf + let (winw, winh) = (fromIntegral _winw, fromIntegral _winh) + let (cx, cy) = (px + w / 2, py + h / 2) + let fp = fontPath conf + let overlay = + Color overlayColor $ + Polygon + [ (-winw, -winh) + , (-winw, winh) + , (winw, winh) + , (winw, -winh) + ] + return $ + Pictures + [ overlay + , Color textColor $ Translate (cx - 45) cy $ TrueTypeText fp 32 "Pause" + ] + + +drawBackground :: StateT TetrisGame (Reader AppConfig) Picture +drawBackground = do + conf <- ask + let (winw, winh) = windowSize conf + let (x, y) = ((fromIntegral winw) / 2, (fromIntegral winh) / 2) + let overlay = + Color backgroundColor $ + Polygon + [ (-x, -y) + , (-x, y) + , (x, y) + , (x, -y) + ] + return overlay + + +-- | Draws the whole window picture +drawWindow :: StateT TetrisGame (Reader AppConfig) Picture +drawWindow = do + backgroundPic <- drawBackground + gamePic <- drawGame + gameState <- get + let pos = fallingPosition gameState + let fig = fallingFigure gameState + let fColor = toGlossColor $ fallingColor gameState + figurePic <- drawFigure fColor pos fig + sidebarPic <- drawSidebar + helpPic <- drawHelp + gridPic <- drawGrid + gameOverOverlayPic <- drawGO $ gameOver gameState + pauseOverlayPic <- drawPO (isPause gameState) (gameOver gameState) + linkPic <- drawL (isPause gameState) + return $ + Pictures + [ backgroundPic + , gridPic + , gamePic + , figurePic + , sidebarPic + , helpPic + , gameOverOverlayPic + , pauseOverlayPic + , linkPic + ] + where + drawGO True = drawGameOver + drawGO False = return $ Pictures [] + drawPO True False = drawPauseOverlay + drawPO _ _ = return $ Pictures [] + drawL False = return $ Pictures [] + drawL True = return $ Pictures [] -- Add True case to complete pattern diff --git a/picture/Tetris/src/Figures.hs b/picture/Tetris/src/Figures.hs new file mode 100644 --- /dev/null +++ b/picture/Tetris/src/Figures.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE ViewPatterns #-} + +module Figures where + +import System.Random + + +-- Tetris figures + +type Block = (Int, Int) +data FigureType = Cube | Tank | Stick | Snake1 | Snake2 | Corner1 | Corner2 + deriving (Enum, Bounded, Show) +data Rotation = D1 | D2 | D3 | D4 + deriving (Enum, Bounded, Show) +data Figure = Figure FigureType Rotation [Block] + deriving (Show) + + +-- Instance of class Random for FigureType +instance Random FigureType where + random g = randomR (minBound, maxBound) g + randomR (a, b) g = case randomR (fromEnum a, fromEnum b) g of + (r, g') -> (toEnum r, g') + + +-- Instance of class Random for Rotation +instance Random Rotation where + random g = randomR (minBound, maxBound) g + randomR (a, b) g = case randomR (fromEnum a, fromEnum b) g of + (r, g') -> (toEnum r, g') + + +-- Rotation +nextRotation :: Rotation -> Rotation +nextRotation D1 = D2 +nextRotation D2 = D3 +nextRotation D3 = D4 +nextRotation D4 = D1 + + +rotate :: Figure -> Figure +rotate (Figure t (nextRotation -> r) _) = getFigures t r + + +------------------------ All Figures ------------------------- + +getFigures :: FigureType -> Rotation -> Figure +getFigures Cube r = Figure Cube r [(0, 0), (0, 1), (-1, 1), (-1, 0)] +getFigures Tank D1 = Figure Tank D1 [(0, 0), (0, 1), (-1, 0), (1, 0)] +getFigures Tank D2 = Figure Tank D2 [(0, 0), (0, 1), (0, -1), (1, 0)] +getFigures Tank D3 = Figure Tank D3 [(0, 0), (0, -1), (-1, 0), (1, 0)] +getFigures Tank D4 = Figure Tank D4 [(0, 0), (0, 1), (0, -1), (-1, 0)] +getFigures Stick D1 = Figure Stick D1 [(0, 0), (-1, 0), (1, 0), (2, 0)] +getFigures Stick D2 = Figure Stick D2 [(0, 0), (0, -1), (0, 1), (0, 2)] +getFigures Stick D3 = Figure Stick D3 [(0, 0), (-1, 0), (1, 0), (2, 0)] +getFigures Stick D4 = Figure Stick D4 [(0, 0), (0, -1), (0, 1), (0, 2)] +getFigures Snake1 D1 = Figure Snake1 D1 [(0, 0), (-1, 0), (0, -1), (1, -1)] +getFigures Snake1 D2 = Figure Snake1 D2 [(0, 0), (0, -1), (1, 0), (1, 1)] +getFigures Snake1 D3 = Figure Snake1 D3 [(0, 0), (-1, 0), (0, -1), (1, -1)] +getFigures Snake1 D4 = Figure Snake1 D4 [(0, 0), (0, -1), (1, 0), (1, 1)] +getFigures Snake2 D1 = Figure Snake2 D1 [(0, 0), (1, 0), (0, -1), (-1, -1)] +getFigures Snake2 D2 = Figure Snake2 D2 [(0, 0), (0, -1), (-1, 0), (-1, 1)] +getFigures Snake2 D3 = Figure Snake2 D3 [(0, 0), (1, 0), (0, -1), (-1, -1)] +getFigures Snake2 D4 = Figure Snake2 D4 [(0, 0), (0, -1), (-1, 0), (-1, 1)] +getFigures Corner1 D1 = Figure Corner1 D1 [(0, 0), (1, 0), (-1, 0), (-1, 1)] +getFigures Corner1 D2 = Figure Corner1 D2 [(0, 0), (0, -1), (0, 1), (1, 1)] +getFigures Corner1 D3 = Figure Corner1 D3 [(0, 0), (1, 0), (1, -1), (-1, 0)] +getFigures Corner1 D4 = Figure Corner1 D4 [(0, 0), (0, -1), (-1, -1), (0, 1)] +getFigures Corner2 D1 = Figure Corner2 D1 [(0, 0), (-1, 0), (1, 0), (1, 1)] +getFigures Corner2 D2 = Figure Corner2 D2 [(0, 0), (0, -1), (1, -1), (0, 1)] +getFigures Corner2 D3 = Figure Corner2 D3 [(0, 0), (-1, 0), (-1, -1), (1, 0)] +getFigures Corner2 D4 = Figure Corner2 D4 [(0, 0), (0, -1), (0, 1), (-1, 1)] diff --git a/picture/Tetris/src/Game.hs b/picture/Tetris/src/Game.hs new file mode 100644 --- /dev/null +++ b/picture/Tetris/src/Game.hs @@ -0,0 +1,173 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + +module Game (runGame) where + +import Config +import Drawing +import World + +import Brillo +import Brillo.Interface.Pure.Game +import Control.Monad (foldM) +import Control.Monad.Reader +import Control.Monad.State +import System.Directory (doesFileExist) +import System.Exit (exitFailure) +import System.IO (hPutStrLn, stderr) + + +runGame :: IO () +runGame = do + fp <- resolveFont + let cfg = defaultAppConfig fp + game <- initState cfg + play + (window cfg) -- Display mode. + background -- Background color. + fps -- Number of simulation steps to take for each second of real time. + game -- The initial world. + (render cfg) -- A function to convert the world a picture. + (handler cfg) -- A function to handle input events. + update -- A function to step the world one iteration. It is passed the period of time (in seconds) needing to be advanced. + + +window :: AppConfig -> Display +window cfg = InWindow "Tetris" (windowSize cfg) (windowPosition cfg) + + +-- | Smallest common multiple +fps :: Int +fps = 24 + + +-- | Hardness fraps per second * (1/fps) +hardnessMod :: Hardness -> Integer +hardnessMod Noob = 24 +hardnessMod Beginner = 12 +hardnessMod Average = 8 +hardnessMod Skilled = 6 +hardnessMod Masterful = 4 +hardnessMod Insane = 3 +hardnessMod Godlike = 2 + + +background :: Color +background = (makeColorI 0 0 0 0) + + +initState :: AppConfig -> IO TetrisGame +initState = runReaderT (initialState) + + +-- | Render function for game +render :: AppConfig -> TetrisGame -> Picture +render cfg game = runReader (evalStateT drawWindow game) cfg + + +-- | Updates game state by shifting current falling figure down +update :: Float -> TetrisGame -> TetrisGame +update _ game = movingDown $ case (isPause game, gameOver game) of + (False, False) -> case (needUpdate) of + True -> shiftDownFigure (game{frapsCounter = 0}) + False -> game{frapsCounter = (frapsCounter game) + 1} + (_, True) -> game{isPause = True} + (True, _) -> game + where + needUpdate = (== 0) $ mod ((+ 1) $ frapsCounter game) (hardnessMod $ hardness game) + movingDown game_ = + if (pressedKeyDown game_ && (not $ isPause game_)) + then (shiftDownFigure game_) + else game_ + + +-- | A function to handle input events. +handler :: AppConfig -> Event -> TetrisGame -> TetrisGame + + +-- | Handles "pause" button +handler _cfg (EventKey (Char 'p') Down _ _) game = + game{isPause = not $ isPause game} +-- \| Handles "reset" button +handler _cfg (EventKey (Char 'r') Down _ _) game = + resetGame game +-- \| Handles Enter to restart on game over +handler _cfg (EventKey (SpecialKey KeyEnter) Down _ _) game + | gameOver game = resetGame game + | otherwise = game +-- \| Handles click on restart button +handler cfg (EventKey (MouseButton LeftButton) Down _ (mx, my)) game + | gameOver game = + let (bx, by, bw, bh) = restartButtonBounds cfg + in if mx >= bx && mx <= bx + bw && my >= by && my <= by + bh + then resetGame game + else game + | otherwise = game +-- \| Handles "left" button press +handler _cfg (EventKey (SpecialKey KeyLeft) Down _ _) game = + case isPause game of + False -> shiftLeftFigure game + True -> game +-- \| Handles "right" button press +handler _cfg (EventKey (SpecialKey KeyRight) Down _ _) game = + case isPause game of + False -> shiftRightFigure game + True -> game +-- \| Handles "down" button press +handler _cfg (EventKey (SpecialKey KeyDown) Down _ _) game = + game{pressedDown = True} +-- \| Handles "down" button up +handler _cfg (EventKey (SpecialKey KeyDown) Up _ _) game = + game{pressedDown = False} +-- \| Handles "up" button +handler _cfg (EventKey (SpecialKey KeyUp) Down _ _) game = + case isPause game of + False -> rotateFigure game + True -> game +-- \| Handles "space" button - hard drop +handler _cfg (EventKey (SpecialKey KeySpace) Down _ _) game = + case isPause game of + False -> dropFigure game + True -> game +-- \| Handles "esc" button +handler _cfg (EventKey (SpecialKey KeyEsc) Down _ _) _ = + error "close game" -- wow! + +-- \| Handles the rest input +handler _ _ game = game + + +-- Font resolution ----------------------------------------------------------- + +candidateFonts :: [FilePath] +candidateFonts = + [ "/System/Library/Fonts/Supplemental/Arial.ttf" + , "/Library/Fonts/Arial.ttf" + , "/System/Library/Fonts/Supplemental/Helvetica.ttc" + , "/System/Library/Fonts/Supplemental/Tahoma.ttf" + , "/usr/share/fonts/truetype/dejavu/DejaVuSans.ttf" + , "/usr/share/fonts/truetype/liberation/LiberationSans-Regular.ttf" + , "/usr/share/fonts/truetype/freefont/FreeSans.ttf" + , "C:\\Windows\\Fonts\\arial.ttf" + , "C:\\Windows\\Fonts\\segoeui.ttf" + ] + + +resolveFont :: IO FilePath +resolveFont = do + found <- foldM pick Nothing candidateFonts + case found of + Just fp -> pure fp + Nothing -> do + hPutStrLn stderr $ + unlines + [ "brillo-tetris: unable to locate a TrueType font." + , "Tried the following paths:" + , unlines (map (" - " <>) candidateFonts) + ] + exitFailure + where + pick (Just fp) _ = pure (Just fp) + pick Nothing candidate = do + exists <- doesFileExist candidate + pure $ if exists then Just candidate else Nothing diff --git a/picture/Tetris/src/Util.hs b/picture/Tetris/src/Util.hs new file mode 100644 --- /dev/null +++ b/picture/Tetris/src/Util.hs @@ -0,0 +1,5 @@ +module Util (sumPair) where + + +sumPair :: (Num a) => (a, a) -> (a, a) -> (a, a) +sumPair (x1, y1) (x2, y2) = (x1 + x2, y1 + y2) diff --git a/picture/Tetris/src/World.hs b/picture/Tetris/src/World.hs new file mode 100644 --- /dev/null +++ b/picture/Tetris/src/World.hs @@ -0,0 +1,307 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} + +module World where + +import Control.Monad.Reader +import Data.List +import Data.Map qualified as Map +import Data.Ord +import System.Random + +import Config +import Figures +import Util + + +type Grid = Map.Map (GridPosition, GameColor) () + + +data Hardness = Noob | Beginner | Average | Skilled | Masterful | Insane | Godlike + deriving (Enum, Bounded, Show) + + +noobBound :: Integer +noobBound = 0 + + +beginnerBound :: Integer +beginnerBound = 300 + + +averageBound :: Integer +averageBound = 800 + + +skilledBound :: Integer +skilledBound = 1400 + + +masterfulBound :: Integer +masterfulBound = 2200 + + +insaneBound :: Integer +insaneBound = 3500 + + +godlikeBound :: Integer +godlikeBound = 5000 + + +-- COLORS + +data GameColor = Red | Yellow | Green | Blue | Violet + deriving (Enum, Bounded, Ord, Eq) + + +-- Instance of class Random for Colors +instance Random GameColor where + random g = randomR (minBound, maxBound) g + randomR (a, b) g = case randomR (fromEnum a, fromEnum b) g of + (r, g') -> (toEnum r, g') + + +-- | Data represents the state of the Tetris game +data TetrisGame = Game + { fallingFigure :: Figure + , fallingPosition :: GridPosition + , startFalling :: GridPosition + , fallingColor :: GameColor + , nextColors :: [GameColor] + , width :: Int + , height :: Int + , nextFigures :: [Figure] + , grid :: Grid + , hardness :: Hardness + , score :: Integer + , frapsCounter :: Integer + , isPause :: Bool + , gameOver :: Bool + , pressedDown :: Bool + } + + +-- | Initial state of the game +initialState :: ReaderT AppConfig IO TetrisGame +initialState = do + cfg <- ask + gen <- liftIO getStdGen + let (f, fs) = case randomFigures gen of + (x : xs) -> (x, xs) + [] -> error "initialState: randomFigures returned empty list" + let (c, cs) = case randoms gen of + (x : xs) -> (x, xs) + [] -> error "initialState: randoms returned empty list" + let startPos = startPosition cfg + return $ + Game + f + startPos + startPos + c + cs + (fst $ gridSize $ cfg) + (snd $ gridSize $ cfg) + fs + Map.empty + minBound + 0 + 0 + False + False + False + + +-- | Real position in Grid +getRealCoords :: Figure -> GridPosition -> [Block] +getRealCoords (Figure _ _ bs) curPos = map (sumPair curPos) bs + + +-- | List of random figures +randomFigures :: (RandomGen g) => g -> [Figure] +randomFigures gen = zipWith getFigures (randoms gen) (randoms gen) + + +-- | Sets the currently falling figure from nextFigures +nextFigureGame :: TetrisGame -> TetrisGame +nextFigureGame g@Game{..} + | checkingGO = g{gameOver = True} + | (nf : nfs) <- nextFigures + , (nc : ncs) <- nextColors = + updateHardness $ + updateScore $ + Game + nf + startFalling + startFalling + nc + ncs + width + height + nfs + updateGrid + hardness + score + frapsCounter + isPause + checkingGO + pressedDown + | otherwise = g{gameOver = True} + where + updateScore gnew = gnew{score = score + (getScore $ countOfBurns g gnew)} + + countOfBurns (length . getGridAsList -> countOld) (length . getGridAsList -> countNew) = div ((countOld + 4) - countNew) width + + -- Returns score based on count of burned lines. + getScore :: Int -> Integer + getScore 0 = 0 + getScore 1 = 100 + getScore 2 = 300 + getScore 3 = 700 + getScore 4 = 1500 + getScore _ = 0 + + updateHardness :: TetrisGame -> TetrisGame + updateHardness game@(Game _ _ _ _ _ _ _ _ _ _ scr _ _ _ _) = game{hardness = nextHardness scr} + + nextHardness :: Integer -> Hardness + nextHardness scr + | scr < beginnerBound = Noob + | scr < averageBound = Beginner + | scr < skilledBound = Average + | scr < masterfulBound = Skilled + | scr < insaneBound = Masterful + | scr < godlikeBound = Insane + | otherwise = Godlike + + updateGrid = + burnFullLines $ + foldl + (\gr bl -> (Map.insert (bl, fallingColor) () gr)) + grid + (getRealCoords fallingFigure fallingPosition) + + checkingGO = any (\(_, y) -> y >= height) (getRealCoords fallingFigure fallingPosition) + + burnFullLines = + listToGrid + . concat + . zipWith + (\num list -> map (\((x, _), color) -> ((x, num), color)) list) + [0, 1 ..] + . filter ((/= width) . length) + . groupBy (\((_, y1), _) ((_, y2), _) -> y1 == y2) + . sortBy (comparing (snd . fst)) + . gridToList + + +-- | Shifts left a figure if able to +shiftLeftFigure :: TetrisGame -> TetrisGame +shiftLeftFigure curTetrisGame@(Game ff (shiftLeft -> fpos) spos fc nc w h fs grid hrd scr fcnt isPs go km) + | goodCoords grid w h (getRealCoords ff fpos) = + Game ff fpos spos fc nc w h fs grid hrd scr fcnt isPs go km + | otherwise = curTetrisGame + + +-- | Shifts right a figure if able to +shiftRightFigure :: TetrisGame -> TetrisGame +shiftRightFigure curTetrisGame@(Game ff (shiftRight -> fpos) spos fc nc w h fs grid hrd scr fcnt isPs go km) + | goodCoords grid w h (getRealCoords ff fpos) = + Game ff fpos spos fc nc w h fs grid hrd scr fcnt isPs go km + | otherwise = curTetrisGame + + +-- | Shifts down a figure if able to +shiftDownFigure :: TetrisGame -> TetrisGame +shiftDownFigure curTetrisGame@(Game ff (shiftDown -> fpos) spos fc nc w h fs grid hrd scr fcnt isPs go km) + | goodCoords grid w h (getRealCoords ff fpos) = + Game ff fpos spos fc nc w h fs grid hrd scr fcnt isPs go km + | otherwise = nextFigureGame curTetrisGame + + +-- | Rotates a figure if able to +rotateFigure :: TetrisGame -> TetrisGame +rotateFigure curTetrisGame@(Game (rotate -> ff) fpos spos fc nc w h fs grid hrd scr fcnt isPs go km) + | goodCoords grid w h (getRealCoords ff fpos) = + Game ff fpos spos fc nc w h fs grid hrd scr fcnt isPs go km + | otherwise = curTetrisGame + + +-- | Instantly drops a figure to the bottom +dropFigure :: TetrisGame -> TetrisGame +dropFigure game = dropUntilCollision game + where + dropUntilCollision currentGame@(Game ff (shiftDown -> fpos) spos fc nc w h fs grid hrd scr fcnt isPs go km) = + if goodCoords grid w h (getRealCoords ff fpos) + then + dropUntilCollision (Game ff fpos spos fc nc w h fs grid hrd scr fcnt isPs go km) + else nextFigureGame currentGame -- Can't move down anymore, lock the piece + + +resetGame :: TetrisGame -> TetrisGame +resetGame Game{..} + | (_ : nf : nfs) <- nextFigures + , (_ : nc : ncs) <- nextColors = + Game + nf + startFalling + startFalling + nc + ncs + width + height + nfs + Map.empty + minBound + 0 + 0 + False + False + pressedDown + | otherwise = error "resetGame: insufficient figures or colors" + + +pressedKeyDown :: TetrisGame -> Bool +pressedKeyDown Game{..} = pressedDown + + +-- | Checks that the point belongs to the Grid and that it is free +goodCoords :: Grid -> Int -> Int -> [Block] -> Bool +goodCoords grid w _h = all goodCoord + where + goodCoord pos@(x, y) = + x >= 0 + && x < w + && y >= 0 + && ((== 0) . (length) . (filter (\(grPos, _) -> grPos == pos)) . gridToList) grid + + +-- | Returns next figure +getNextFigure :: TetrisGame -> Figure +getNextFigure (nextFigures -> (f : _)) = f +getNextFigure _ = error "getNextFigure: no next figure available" + + +getGridAsList :: TetrisGame -> [(GridPosition, GameColor)] +getGridAsList (grid -> gr) = gridToList gr + + +listToGrid :: [(GridPosition, GameColor)] -> Grid +listToGrid = Map.fromList . (`zip` repeat ()) + + +gridToList :: Grid -> [(GridPosition, GameColor)] +gridToList = Map.keys + + +shiftRight :: GridPosition -> GridPosition +shiftRight = sumPair (1, 0) + + +shiftLeft :: GridPosition -> GridPosition +shiftLeft = sumPair (-1, 0) + + +shiftDown :: GridPosition -> GridPosition +shiftDown = sumPair (0, -1) diff --git a/picture/TicTacToe/Main.hs b/picture/TicTacToe/Main.hs new file mode 100644 --- /dev/null +++ b/picture/TicTacToe/Main.hs @@ -0,0 +1,204 @@ +module Main where + +import Brillo +import Brillo.Interface.IO.Game +import Control.Concurrent +import Control.Monad (void) +import Data.Array +import Data.Maybe (isNothing) +import Data.Text qualified as T +import System.Random (randomRIO) + + +-- | Main entry point +main :: IO () +main = do + aiMove <- newEmptyMVar + playIO + (InWindow (T.pack "Tic Tac Toe") (600, 600) (10, 10)) + white + 30 + (initialBoard, X, aiMove, Playing) + drawBoard + (handleInput aiMove) + (stepGame aiMove) + + +-- | Game state types +data Play = X | O deriving (Eq, Show) + + +type Board = Array (Int, Int) (Maybe Play) + + +data GameState = Playing | Won Play | Draw deriving (Eq, Show) + + +-- | Initial empty board +initialBoard :: Board +initialBoard = listArray ((0, 0), (2, 2)) (replicate 9 Nothing) + + +-- | Draw the game board +drawBoard :: (Board, Play, MVar Board, GameState) -> IO Picture +drawBoard (board, _, _, gameState) = return (grid <> plays <> status) + where + grid = + Pictures + [ Color (greyN 0.3) $ Line [(-150, -50), (150, -50)] + , Color (greyN 0.3) $ Line [(-150, 50), (150, 50)] + , Color (greyN 0.3) $ Line [(-50, -150), (-50, 150)] + , Color (greyN 0.3) $ Line [(50, -150), (50, 150)] + ] + + plays = Pictures [drawPlay x y p | ((x, y), p) <- assocs board] + + drawPlay _ _ Nothing = Blank + drawPlay x y (Just p) = + Translate (fromIntegral (x - 1) * 100) (fromIntegral (1 - y) * 100) $ + drawPiece p + + drawPiece X = + Color red $ + Pictures + [ Rotate 45 $ rectangleSolid 80 10 + , Rotate (-45) $ rectangleSolid 80 10 + ] + drawPiece O = Color blue $ ThickCircle 30 10 + + status = case gameState of + Won X -> + Pictures + [ Translate (-90) 220 $ + Scale 0.3 0.3 $ + Color red $ + Text (T.pack "X Wins!") + , Translate (-140) 180 $ + Scale 0.15 0.15 $ + Color (greyN 0.5) $ + Text (T.pack "Press R to restart") + ] + Won O -> + Pictures + [ Translate (-90) 220 $ + Scale 0.3 0.3 $ + Color blue $ + Text (T.pack "O Wins!") + , Translate (-140) 180 $ + Scale 0.15 0.15 $ + Color (greyN 0.5) $ + Text (T.pack "Press R to restart") + ] + Draw -> + Pictures + [ Translate (-60) 220 $ + Scale 0.3 0.3 $ + Color black $ + Text (T.pack "Draw!") + , Translate (-140) 180 $ + Scale 0.15 0.15 $ + Color (greyN 0.5) $ + Text (T.pack "Press R to restart") + ] + Playing -> Blank + + +-- | Handle user input +handleInput :: + MVar Board -> + Event -> + (Board, Play, MVar Board, GameState) -> + IO (Board, Play, MVar Board, GameState) +-- Restart game on 'R' key press +handleInput aiMove (EventKey (Char 'r') Down _ _) (_, _, mv, _) = do + -- Clear any pending AI move + _ <- tryTakeMVar aiMove + return (initialBoard, X, mv, Playing) +-- Handle mouse click during play +handleInput + aiMove + (EventKey (MouseButton LeftButton) Up _ (x, y)) + (board, X, mv, Playing) = do + let snapX = 1 + fromIntegral (floor ((x + 50) / 100) :: Integer) :: Int + snapY = 1 - fromIntegral (floor ((y + 50) / 100) :: Integer) :: Int + gridX = max 0 (min 2 snapX) + gridY = max 0 (min 2 snapY) + + case board ! (gridX, gridY) of + Just _ -> return (board, X, mv, Playing) -- Cell already occupied + Nothing -> do + let newBoard = board // [((gridX, gridY), Just X)] + newState = checkGameState newBoard + case newState of + Playing -> do + forkAi aiMove newBoard + return (newBoard, O, mv, newState) + _ -> return (newBoard, X, mv, newState) +handleInput _ _ state = return state + + +-- | Fork AI computation in background +forkAi :: MVar Board -> Board -> IO () +forkAi aiMove board = void $ forkIO $ do + -- Random delay to simulate thinking + threadDelay =<< randomRIO (100000, 1000000) + + -- Find all valid moves + let plays = + [ board // [((x, y), Just O)] + | x <- [0 .. 2] + , y <- [0 .. 2] + , isNothing (board ! (x, y)) + ] + + case plays of + [] -> putMVar aiMove board -- No moves available + _ -> do + -- Pick a random move + idx <- randomRIO (0, length plays - 1) + putMVar aiMove (plays !! idx) + + +-- | Step the game forward +stepGame :: + MVar Board -> + Float -> + (Board, Play, MVar Board, GameState) -> + IO (Board, Play, MVar Board, GameState) +stepGame aiMove _ (board, O, mv, Playing) = do + maybeBoard <- tryTakeMVar aiMove + case maybeBoard of + Nothing -> return (board, O, mv, Playing) + Just newBoard -> + let newState = checkGameState newBoard + in return (newBoard, X, mv, newState) +stepGame _ _ state = return state + + +-- | Check if the game is over +checkGameState :: Board -> GameState +checkGameState board + | hasWon X board = Won X + | hasWon O board = Won O + | isFull board = Draw + | otherwise = Playing + + +-- | Check if a player has won +hasWon :: Play -> Board -> Bool +hasWon player board = + any (all (== Just player)) allLines + where + allLines = + [[board ! (i, j) | i <- [0 .. 2]] | j <- [0 .. 2]] -- rows + ++ [[board ! (i, j) | j <- [0 .. 2]] | i <- [0 .. 2]] -- columns + ++ [[board ! (i, i) | i <- [0 .. 2]]] -- diagonal \ + ++ [[board ! (i, 2 - i) | i <- [0 .. 2]]] -- diagonal / + + +-- | Check if the board is full +isFull :: Board -> Bool +isFull board = + all + (\(_, cell) -> case cell of Just _ -> True; Nothing -> False) + (assocs board) diff --git a/picture/Tree/Main.hs b/picture/Tree/Main.hs --- a/picture/Tree/Main.hs +++ b/picture/Tree/Main.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + {-| Tree Fractal. Based on ANUPlot code by Clem Baker-Finch. -} @@ -39,11 +41,11 @@ -- Make a tree fractal. -tree - :: Int -- Fractal degree - -> Float -- time - -> Color -- Color for the stump - -> Picture +tree :: + Int -> -- Fractal degree + Float -> -- time + Color -> -- Color for the stump + Picture tree 0 _time colr = stump colr tree n time colr = let smallTree = diff --git a/picture/TrueType/Main.hs b/picture/TrueType/Main.hs new file mode 100644 --- /dev/null +++ b/picture/TrueType/Main.hs @@ -0,0 +1,347 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} + +-- | Demonstrate rendering TrueType fonts with Brillo. +module Main (main) where + +import Brillo +import Control.Exception (bracket, try) +import Control.Monad (foldM, forM) +import Data.Char (ord) +import Data.List (foldl1', isPrefixOf) +import Data.Maybe (listToMaybe) +import Data.Text (Text) +import Data.Text qualified as T +import Foreign (peek) +import FreeType ( + FT_Bitmap (bRows, bWidth), + FT_Face, + FT_FaceRec (frGlyph), + FT_GlyphSlotRec ( + gsrAdvance, + gsrBitmap, + gsrBitmap_left, + gsrBitmap_top + ), + FT_Vector (vX), + ft_Done_Face, + ft_Done_FreeType, + ft_Init_FreeType, + ft_Load_Char, + ft_New_Face, + ft_Set_Pixel_Sizes, + pattern FT_LOAD_RENDER, + ) +import FreeType.Exception (FtError) +import System.Directory (doesFileExist) +import System.Environment (getArgs) +import System.Exit (exitFailure) +import System.IO (hPutStrLn, stderr) + + +main :: IO () +main = do + args <- getArgs + let fontArg = listToMaybe [a | a <- args, not ("--" `isPrefixOf` a)] + fontPath <- resolveFont fontArg + SceneAssets{sceneWindowSize, scenePicture} <- buildScene fontPath + let window = + InWindow + "Brillo TrueType" + sceneWindowSize + windowPosition + display window white scenePicture + + +windowPosition :: (Int, Int) +windowPosition = (40, 40) + + +buildScene :: FilePath -> IO SceneAssets +buildScene fontPath = do + measured <- + forM textItems $ \item -> do + bounds <- measureTrueTypeBounds fontPath (tiPixelHeight item) (tiContent item) + let translatedBounds = translateBounds (tiOffset item) bounds + picture = + Translate dx dy $ + Color (tiColor item) $ + TrueTypeText fontPath (tiPixelHeight item) (tiContent item) + where + (dx, dy) = tiOffset item + pure (picture, translatedBounds) + let contentBounds = foldl1' unionBounds (map snd measured) + padding = 40 + paddedBounds = + expandBounds + padding + padding + padding + padding + contentBounds + width = boundsWidth paddedBounds + height = boundsHeight paddedBounds + centerX = (boundsMinX paddedBounds + boundsMaxX paddedBounds) / 2 + centerY = (boundsMinY paddedBounds + boundsMaxY paddedBounds) / 2 + offsetX = -centerX + offsetY = -centerY + background = + Translate centerX centerY $ + Color (makeColor 0.08 0.09 0.12 1.0) $ + rectangleSolid width height + picture = + Translate offsetX offsetY $ + Pictures (background : map fst measured) + widthPixels = max 200 (ceiling width) + heightPixels = max 200 (ceiling height) + pure + SceneAssets + { sceneWindowSize = (widthPixels, heightPixels) + , scenePicture = picture + } + + +data SceneAssets = SceneAssets + { sceneWindowSize :: (Int, Int) + , scenePicture :: Picture + } + + +data TextItem = TextItem + { tiOffset :: (Float, Float) + , tiColor :: Color + , tiPixelHeight :: Int + , tiContent :: Text + } + + +textItems :: [TextItem] +textItems = + [ TextItem + { tiOffset = (-360, 180) + , tiColor = makeColor 0.96 0.85 0.45 1.0 + , tiPixelHeight = 56 + , tiContent = "TrueType rendering" + } + , TextItem + { tiOffset = (-420, 60) + , tiColor = makeColor 0.75 0.95 1.0 1.0 + , tiPixelHeight = 32 + , tiContent = "Brillo now loads glyphs via FreeType." + } + , TextItem + { tiOffset = (-420, 10) + , tiColor = makeColor 0.85 0.75 1.0 1.0 + , tiPixelHeight = 32 + , tiContent = "Kerning, hinting and newlines all work!" + } + , TextItem + { tiOffset = (-420, -40) + , tiColor = makeColor 0.8 1.0 0.75 1.0 + , tiPixelHeight = 32 + , tiContent = "Pass a custom font path via CLI arguments." + } + , TextItem + { tiOffset = (-420, -130) + , tiColor = makeColor 0.95 0.95 0.95 1.0 + , tiPixelHeight = 24 + , tiContent = "Multi-line text is supported:\nLine one\nLine two\nLine three" + } + ] + + +measureTrueTypeBounds :: FilePath -> Int -> Text -> IO Bounds +measureTrueTypeBounds fontPath pixelHeight txt + | T.null txt = pure zeroBounds + | otherwise = do + let lineHeight = fromIntegral pixelHeight :: Float + lineCount = max 1 (length (T.splitOn "\n" txt)) + bracket ft_Init_FreeType ft_Done_FreeType $ \library -> + bracket (ft_New_Face library fontPath 0) ft_Done_Face $ \face -> do + ft_Set_Pixel_Sizes face 0 (fromIntegral pixelHeight) + (mbBounds, penX, penY, maxPenX, minSeenY, maxSeenY) <- + foldM + (accumulate face lineHeight) + (Nothing, 0, 0, 0, 0, 0) + (T.unpack txt) + let maxPenX' = max maxPenX penX + minSeenY' = min minSeenY penY + maxSeenY' = max maxSeenY penY + baseBounds = + case mbBounds of + Nothing -> + Bounds + { boundsMinX = 0 + , boundsMaxX = max maxPenX' lineHeight + , boundsMinY = negate (fromIntegral lineCount - 1) * lineHeight + , boundsMaxY = lineHeight + } + Just b -> + Bounds + { boundsMinX = min (boundsMinX b) 0 + , boundsMaxX = max (boundsMaxX b) (max maxPenX' lineHeight) + , boundsMinY = min (boundsMinY b) minSeenY' + , boundsMaxY = max (boundsMaxY b) (max maxSeenY' lineHeight) + } + ensuredHeight = + if boundsHeight baseBounds <= 0 + then baseBounds{boundsMaxY = boundsMinY baseBounds + lineHeight} + else baseBounds + pure ensuredHeight + where + accumulate :: + FT_Face -> + Float -> + (Maybe Bounds, Float, Float, Float, Float, Float) -> + Char -> + IO (Maybe Bounds, Float, Float, Float, Float, Float) + accumulate face lineHeight (mbBounds, penX, penY, maxPenX, minSeenY, maxSeenY) ch + | ch == '\r' = + pure (mbBounds, penX, penY, maxPenX, minSeenY, maxSeenY) + | ch == '\n' = + let maxPenX' = max maxPenX penX + maxSeenY' = max maxSeenY penY + newPenY = penY - lineHeight + minSeenY' = min minSeenY newPenY + in pure (mbBounds, 0, newPenY, maxPenX', minSeenY', maxSeenY') + | otherwise = do + loadResult <- + try (ft_Load_Char face (fromIntegral (ord ch)) FT_LOAD_RENDER) :: + IO (Either FtError ()) + case loadResult of + Left _ -> + pure (mbBounds, penX, penY, maxPenX, minSeenY, maxSeenY) + Right () -> do + faceRec <- peek face + glyphSlot <- peek (frGlyph faceRec) + let glyphBitmap = gsrBitmap glyphSlot + width = fromIntegral (bWidth glyphBitmap) :: Float + height = fromIntegral (bRows glyphBitmap) :: Float + bearingX = fromIntegral (gsrBitmap_left glyphSlot) :: Float + bearingY = fromIntegral (gsrBitmap_top glyphSlot) :: Float + xpos = penX + bearingX + ypos = penY + bearingY - height + top = ypos + height + right = xpos + width + glyphBounds = + if width <= 0 && height <= 0 + then Nothing + else + Just + Bounds + { boundsMinX = xpos + , boundsMaxX = right + , boundsMinY = ypos + , boundsMaxY = top + } + bounds' = + case (mbBounds, glyphBounds) of + (Nothing, Nothing) -> Nothing + (Just b, Nothing) -> Just b + (Nothing, Just g) -> Just g + (Just b, Just g) -> Just (unionBounds b g) + advance = realToFrac (vX (gsrAdvance glyphSlot)) / 64 + penX' = penX + advance + maxPenX' = max maxPenX penX' + minSeenY' = min minSeenY (min ypos penY) + maxSeenY' = max maxSeenY (max top penY) + pure (bounds', penX', penY, maxPenX', minSeenY', maxSeenY') + + +data Bounds = Bounds + { boundsMinX :: !Float + , boundsMaxX :: !Float + , boundsMinY :: !Float + , boundsMaxY :: !Float + } + deriving (Show) + + +zeroBounds :: Bounds +zeroBounds = Bounds 0 0 0 0 + + +boundsWidth :: Bounds -> Float +boundsWidth Bounds{boundsMinX, boundsMaxX} = boundsMaxX - boundsMinX + + +boundsHeight :: Bounds -> Float +boundsHeight Bounds{boundsMinY, boundsMaxY} = boundsMaxY - boundsMinY + + +unionBounds :: Bounds -> Bounds -> Bounds +unionBounds a b = + Bounds + { boundsMinX = min (boundsMinX a) (boundsMinX b) + , boundsMaxX = max (boundsMaxX a) (boundsMaxX b) + , boundsMinY = min (boundsMinY a) (boundsMinY b) + , boundsMaxY = max (boundsMaxY a) (boundsMaxY b) + } + + +translateBounds :: (Float, Float) -> Bounds -> Bounds +translateBounds (dx, dy) Bounds{boundsMinX, boundsMaxX, boundsMinY, boundsMaxY} = + Bounds + { boundsMinX = boundsMinX + dx + , boundsMaxX = boundsMaxX + dx + , boundsMinY = boundsMinY + dy + , boundsMaxY = boundsMaxY + dy + } + + +expandBounds :: Float -> Float -> Float -> Float -> Bounds -> Bounds +expandBounds padLeft padRight padBottom padTop Bounds{boundsMinX, boundsMaxX, boundsMinY, boundsMaxY} = + Bounds + { boundsMinX = boundsMinX - padLeft + , boundsMaxX = boundsMaxX + padRight + , boundsMinY = boundsMinY - padBottom + , boundsMaxY = boundsMaxY + padTop + } + + +resolveFont :: Maybe FilePath -> IO FilePath +resolveFont (Just fp) = ensureFont fp +resolveFont Nothing = do + found <- foldM pick Nothing candidateFonts + case found of + Just fp -> pure fp + Nothing -> do + hPutStrLn stderr $ + unlines + [ "brillo-truetype: unable to locate a TrueType font." + , "Tried the following paths:" + , unlines (map (" • " <>) candidateFonts) + , "Pass a font explicitly: stack run brillo-truetype -- /path/to/font.ttf" + ] + exitFailure + where + pick acc candidate = + case acc of + Just _ -> pure acc + Nothing -> do + exists <- doesFileExist candidate + pure $ if exists then Just candidate else Nothing + + +ensureFont :: FilePath -> IO FilePath +ensureFont fp = do + exists <- doesFileExist fp + if exists + then pure fp + else do + hPutStrLn stderr $ "brillo-truetype: font file not found: " <> fp + exitFailure + + +candidateFonts :: [FilePath] +candidateFonts = + [ "/System/Library/Fonts/Supplemental/Arial.ttf" + , "/Library/Fonts/Arial.ttf" + , "/System/Library/Fonts/Supplemental/Helvetica.ttc" + , "/System/Library/Fonts/Supplemental/Tahoma.ttf" + , "/usr/share/fonts/truetype/dejavu/DejaVuSans.ttf" + , "/usr/share/fonts/truetype/liberation/LiberationSans-Regular.ttf" + , "/usr/share/fonts/truetype/freefont/FreeSans.ttf" + , "C:\\\\Windows\\\\Fonts\\\\arial.ttf" + , "C:\\\\Windows\\\\Fonts\\\\segoeui.ttf" + ] diff --git a/picture/Visibility/Draw.hs b/picture/Visibility/Draw.hs --- a/picture/Visibility/Draw.hs +++ b/picture/Visibility/Draw.hs @@ -7,9 +7,8 @@ where import Brillo ( - Picture (Color, Line, Pictures, ThickCircle, Translate), + Picture (Blank, Color, Line, Pictures, ThickCircle, Translate), Point, - blank, dim, green, greyN, @@ -85,14 +84,14 @@ ] in Color red $ Pictures [picTarget, picLine, picSegsHit] | otherwise = - blank + Blank -- overlay picOverlay | ModeOverlayVisApprox <- modeOverlay = drawVisGrid 10 pView world | otherwise = - blank + Blank in Pictures [picOverlay, picWorld, picView, picTargets] diff --git a/picture/Visibility/Geometry/Randomish.hs b/picture/Visibility/Geometry/Randomish.hs --- a/picture/Visibility/Geometry/Randomish.hs +++ b/picture/Visibility/Geometry/Randomish.hs @@ -14,16 +14,16 @@ -- | Some uniformly distributed points -randomishPoints - :: Int - -- ^ seed - -> Int - -- ^ number of points - -> Float - -- ^ minimum coordinate - -> Float - -- ^ maximum coordinate - -> V.Vector (Float, Float) +randomishPoints :: + -- | seed + Int -> + -- | number of points + Int -> + -- | minimum coordinate + Float -> + -- | maximum coordinate + Float -> + V.Vector (Float, Float) randomishPoints seed' n pointMin pointMax = let pts = randomishFloats (n * 2) pointMin pointMax seed' xs = G.slice 0 n pts @@ -40,12 +40,12 @@ Stephen K. Park and Keith W. Miller. Communications of the ACM, Oct 1988, Volume 31, Number 10. -} -randomishInts - :: Int -- Length of vector. - -> Int -- Minumum value in output. - -> Int -- Maximum value in output. - -> Int -- Random seed. - -> V.Vector Int -- Vector of random numbers. +randomishInts :: + Int -> -- Length of vector. + Int -> -- Minumum value in output. + Int -> -- Maximum value in output. + Int -> -- Random seed. + V.Vector Int -- Vector of random numbers. randomishInts !len !valMin' !valMax' !seed' = let -- a magic number (don't change it) @@ -87,12 +87,12 @@ {-| Generate some randomish doubles with terrible statistical properties. This is good enough for test data, but not much else. -} -randomishDoubles - :: Int -- Length of vector - -> Double -- Minimum value in output - -> Double -- Maximum value in output - -> Int -- Random seed. - -> V.Vector Double -- Vector of randomish doubles. +randomishDoubles :: + Int -> -- Length of vector + Double -> -- Minimum value in output + Double -> -- Maximum value in output + Int -> -- Random seed. + V.Vector Double -- Vector of randomish doubles. randomishDoubles !len !valMin !valMax !seed = let range = valMax - valMin @@ -105,12 +105,12 @@ {-| Generate some randomish doubles with terrible statistical properties. This is good enough for test data, but not much else. -} -randomishFloats - :: Int -- Length of vector - -> Float -- Minimum value in output - -> Float -- Maximum value in output - -> Int -- Random seed. - -> V.Vector Float -- Vector of randomish doubles. +randomishFloats :: + Int -> -- Length of vector + Float -> -- Minimum value in output + Float -> -- Maximum value in output + Int -> -- Random seed. + V.Vector Float -- Vector of randomish doubles. randomishFloats !len !valMin !valMax !seed = let range = valMax - valMin diff --git a/picture/Visibility/Main.hs b/picture/Visibility/Main.hs --- a/picture/Visibility/Main.hs +++ b/picture/Visibility/Main.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + {-| Visibility on the 2D plane. Uses an instance of Warnocks algorithm. TODO: animate the line segments, make them spin and move around so we can see diff --git a/picture/Zen/Main.hs b/picture/Zen/Main.hs --- a/picture/Zen/Main.hs +++ b/picture/Zen/Main.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + -- A nifty animated fractal of a tree, superimposed on a background -- of three red rectangles. import Brillo