packages feed

brillo-examples 1.13.3 → 2.0.0

raw patch · 63 files changed

+8671/−321 lines, 63 filesdep +FULEdep +arraydep +brillo-exportdep −bmpdep −bytestringdep −ghc-primdep ~brillodep ~brillo-algorithmsdep ~brillo-renderingnew-component:exe:brillo-2048new-component:exe:brillo-antialiasingnew-component:exe:brillo-canvas-editornew-component:exe:brillo-chessnew-component:exe:brillo-circle-comparisonnew-component:exe:brillo-cursorsnew-component:exe:brillo-dropfilesnew-component:exe:brillo-exportnew-component:exe:brillo-fule-layoutnew-component:exe:brillo-guinew-component:exe:brillo-interactionnew-component:exe:brillo-linesnew-component:exe:brillo-pacmannew-component:exe:brillo-pickfilesnew-component:exe:brillo-polygonsnew-component:exe:brillo-snakenew-component:exe:brillo-tetrisnew-component:exe:brillo-tictactoenew-component:exe:brillo-truetype

Dependencies added: FULE, array, brillo-export, directory, freetype2, mtl, split, text

Dependencies removed: bmp, bytestring, ghc-prim

Dependency ranges changed: brillo, brillo-algorithms, brillo-rendering, containers

Files

brillo-examples.cabal view
@@ -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
+ picture/2048/Main.hs view
@@ -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)
+ picture/Antialiasing/Main.hs view
@@ -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]+    ]
picture/Bitmap/Main.hs view
@@ -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)
picture/Boids/KDTree2d.hs view
@@ -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.
picture/Boids/Main.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE OverloadedStrings #-}+ -- Implementation of the Boids flocking algorithm. --   by Matthew Sottile <matt@galois.com> <mjsottile@computer.org> --   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
+ picture/CanvasEditor/Main.hs view
@@ -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"+  ]
+ picture/Chess/Main.hs view
@@ -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)]+    ]
+ picture/CircleComparison/Main.hs view
@@ -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
picture/Clock/Main.hs view
@@ -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         ]
picture/Color/Main.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ParallelListComp #-}  -- Draw a color wheel.
picture/Conway/Cell.hs view
@@ -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
picture/Conway/Main.hs view
@@ -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
+ picture/Cursors/Main.hs view
@@ -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"+  ]
picture/Draw/Main.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-}  {-| Simple picture drawing application.
+ picture/DropFiles/Main.hs view
@@ -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
picture/Easy/Main.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE OverloadedStrings #-}+ module Main where  import Brillo
picture/Eden/Main.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE OverloadedStrings #-}+ -- Adapted from ANUPlot version by Clem Baker-Finch module Main where
picture/Eden/World.hs view
@@ -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
+ picture/Export/Main.hs view
@@ -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)"
picture/Flake/Main.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE OverloadedStrings #-}+ {-| Snowflake Fractal.      Based on ANUPlot code by Clem Baker-Finch. -}
+ picture/FuleLayout/Main.hs view
@@ -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
+ picture/GUI/Main.hs view
@@ -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"+  ]
picture/GameEvent/Main.hs view
@@ -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)
picture/Graph/Main.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE OverloadedStrings #-}+ -- See <http://mazzo.li/posts/graph-drawing.html> 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
picture/Gravity/Main.hs view
@@ -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
picture/Hello/Main.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE OverloadedStrings #-}+ -- | Display "Hello World" in a window. module Main where
+ picture/Interaction/Main.hs view
@@ -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 ())
picture/Lifespan/Community.hs view
@@ -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
picture/Lifespan/Main.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE OverloadedStrings #-}+ -- Adapted from ANUPlot version by Clem Baker-Finch module Main where
picture/Lifespan/World.hs view
@@ -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
+ picture/Lines/Main.hs view
@@ -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
picture/Machina/Main.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE OverloadedStrings #-}+ module Main where  import Brillo
picture/Occlusion/Cell.hs view
@@ -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
picture/Occlusion/Main.hs view
@@ -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 $
picture/Occlusion/World.hs view
@@ -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.
+ picture/PacMan/GhostAI.hs view
@@ -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
+ picture/PacMan/Main.hs view
@@ -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
+ picture/PacMan/Maze.hs view
@@ -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]
+ picture/PacMan/Structs.hs view
@@ -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+  }
+ picture/PickFiles/Main.hs view
@@ -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
+ picture/Polygons/Main.hs view
@@ -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]
+ picture/Snake/Main.hs view
@@ -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
picture/Styrene/Actor.hs view
@@ -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
picture/Styrene/Advance.hs view
@@ -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 =
picture/Styrene/Collide.hs view
@@ -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
picture/Styrene/Contact.hs view
@@ -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
picture/Styrene/Main.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE OverloadedStrings #-}+ module Main where  import Actor (Actor (..))
picture/Styrene/QuadTree.hs view
@@ -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 ->
+ picture/Tetris/Main.hs view
@@ -0,0 +1,5 @@+import Game+++main :: IO ()+main = runGame
+ picture/Tetris/src/Config.hs view
@@ -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)
+ picture/Tetris/src/Drawing.hs view
@@ -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
+ picture/Tetris/src/Figures.hs view
@@ -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)]
+ picture/Tetris/src/Game.hs view
@@ -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
+ picture/Tetris/src/Util.hs view
@@ -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)
+ picture/Tetris/src/World.hs view
@@ -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)
+ picture/TicTacToe/Main.hs view
@@ -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)
picture/Tree/Main.hs view
@@ -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 =
+ picture/TrueType/Main.hs view
@@ -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"+  ]
picture/Visibility/Draw.hs view
@@ -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]
picture/Visibility/Geometry/Randomish.hs view
@@ -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
picture/Visibility/Main.hs view
@@ -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
picture/Zen/Main.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE OverloadedStrings #-}+ -- A nifty animated fractal of a tree, superimposed on a background --      of three red rectangles. import Brillo