From 48af4f917cba435aa43d4eb4fed701eead880f94 Mon Sep 17 00:00:00 2001 From: Eric Mertens Date: Wed, 30 Nov 2022 13:38:12 -0800 Subject: [PATCH] =?UTF-8?q?=F0=9F=90=A3?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- .gitignore | 2 + CHANGELOG.md | 5 + LICENSE | 13 +++ app/Main.hs | 261 ++++++++++++++++++++++++++++++++++++++++++++++++++ parabox.cabal | 27 ++++++ 5 files changed, 308 insertions(+) create mode 100644 .gitignore create mode 100644 CHANGELOG.md create mode 100644 LICENSE create mode 100644 app/Main.hs create mode 100644 parabox.cabal diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..4aa2854 --- /dev/null +++ b/.gitignore @@ -0,0 +1,2 @@ +/dist-newstyle +cabal.project.local diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 index 0000000..a043ceb --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for parabox + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..f78ee94 --- /dev/null +++ b/LICENSE @@ -0,0 +1,13 @@ +Copyright (c) 2022 Eric Mertens + +Permission to use, copy, modify, and/or distribute this software for any purpose +with or without fee is hereby granted, provided that the above copyright notice +and this permission notice appear in all copies. + +THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH +REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND +FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, +INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS +OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER +TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF +THIS SOFTWARE. diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 index 0000000..e60387e --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,261 @@ +{-# Language ImportQualifiedPost, BlockArguments, LambdaCase #-} +module Main where + +import Data.Array +import Data.Map (Map) +import Data.Map qualified as Map +import Graphics.Vty +import Control.Exception +import Data.List (intersperse) +import Data.List.NonEmpty (NonEmpty(..)) +import Data.List.NonEmpty qualified as NonEmpty +import Debug.Trace +import Control.Monad +import Data.Maybe +import Data.Set (Set) +import Data.Set qualified as Set + +type Coord = (Int, Int) + +data Box = Box { + boxLocation :: Location, + boxWalls :: Array Coord Bool, + boxColor :: Attr +} + deriving (Show, Read, Eq) + +data Location = Location Char Int Int + deriving (Read, Show, Ord, Eq) + +data World = World { + worldBoxes :: Map Char Box, + worldMe :: Char +} + deriving (Show, Read, Eq) + +renderBox :: World -> Map Location Char -> Box -> Char -> Image +renderBox world locMap box boxName = + vertCat + [ + horizCat + [ + if boxWalls box ! (y,x) then char myAttr '▓' + else case Map.lookup (Location boxName y x) locMap of + Nothing -> char myAttr '░' + Just n -> char (boxColor (worldBoxes world Map.! n)) n + | x <- [xlo .. xhi] + ] + + | let ((ylo,xlo),(yhi,xhi)) = bounds (boxWalls box) + , let myAttr = boxColor box + , y <- [ylo .. yhi] + ] + +makeWalls :: [String] -> Array Coord Bool +makeWalls rows = listArray ((ylo,xlo),(yhi,xhi)) (map (' '/=) (concat rows)) + where + h = length rows + w = length (head rows) + (xlo,xhi) = mkRange w + (ylo,yhi) = mkRange h + +mkRange n = (- (n-1)`div`2, n`div`2) + +drawWorld :: World -> Image +drawWorld world = + horizCat $ + intersperse (char defAttr ' ') + [ + renderBox world locMap box boxName + | (boxName, box) <- Map.toList (worldBoxes world) + ] + where + locMap = Map.fromList [(boxLocation loc, n) | (n, loc) <- Map.toList (worldBoxes world)] + +world0 :: World +world0 = World { + worldMe = 'b', + worldBoxes = Map.fromList + [('1', Box { + boxColor = withForeColor defAttr green, + boxLocation = Location '1' (-1) 0, + boxWalls = makeWalls [ + "▓▓▓ ▓▓▓", + "▓ ▓", + "▓ ▓", + "▓ ▓", + "▓ ▓", + "▓ ▓ ▓", + "▓ ▓", + "▓ ▓", + "▓▓▓ ▓ ▓▓▓" + ] + }), + ('2', Box { + boxColor = withForeColor defAttr cyan, + boxLocation = Location '1' 1 1, + boxWalls = makeWalls [ + "▓▓▓▓ ▓▓▓▓", + "▓ ▓", + "▓ ▓", + " ", + "▓ ▓", + "▓ ▓", + "▓▓▓▓ ▓▓▓▓" + ] + + }), + ('b', Box { + boxColor = withForeColor defAttr red, + boxLocation = Location '1' 0 1, + boxWalls = makeWalls [ + "▓ ▓", + " ", + "▓ ▓" + ] + }), + ('x', Box { + boxColor = withForeColor defAttr yellow, + boxLocation = Location '1' 0 (-1), + boxWalls = makeWalls ["▓"] + }), + ('y', Box { + boxColor = withForeColor defAttr magenta, + boxLocation = Location '1' 0 (-2), + boxWalls = makeWalls ["▓"] + }) + + ] + } + +-- Move an object +-- 1. remove it from the world +-- 2. compute where it would move to +-- 3. a. that spot is empty +-- b. try to move that object forward +-- c. try to move that object backward into me + +move :: World -> (Int,Int) -> World +move world dir = + case moveBlock world Map.empty (myLocation world) dir of + Nothing -> world + Just changes -> + let f box = box { boxLocation = Map.findWithDefault (boxLocation box) (boxLocation box) changes } in + world { worldBoxes = fmap f (worldBoxes world)} + +myLocation :: World -> Location +myLocation world = + boxLocation (worldBoxes world Map.! worldMe world) + +isWall :: Location -> World -> Bool +isWall (Location n y x) world = + case Map.lookup n (worldBoxes world) of + Nothing -> True + Just box -> boxWalls box ! (y,x) + +main :: IO () +main = + bracket (mkVty =<< userConfig) shutdown \vty -> + do + loop vty (pure world0) + pure () + +loop :: Vty -> NonEmpty World -> IO () +loop vty (world :| history) = + do update vty (picForImage (drawWorld world)) + ev <- nextEvent vty + case ev of + EvKey key _modifier -> + case key of + KUp -> loop vty (move world (-1,0) :| world : history) + KDown -> loop vty (move world (1,0) :| world : history) + KLeft -> loop vty (move world (0,-1) :| world : history) + KRight -> loop vty (move world (0,1) :| world : history) + KChar 'z' + | Just worlds <- NonEmpty.nonEmpty history -> + loop vty worlds + KEsc -> pure () + _ -> loop vty (world :| history) + _ -> loop vty (world :| history) + +type Movement = (Int, Int) + +moveBlock :: + World -> + Map Location (Int, Location) -> + Location -> + Movement -> + Maybe (Map Location Location) + +-- moving into a wall, not possible +moveBlock world visited loc _ + | isWall loc world = Nothing + +-- move introduced a loop, trim off the tail and report success +moveBlock world visited loc _ + | Just (n,_) <- Map.lookup loc visited + = Just (fmap snd (Map.filter (\(a,_)->a >= n) visited)) + +moveBlock world visited loc dir = + case [(n,box) | (n,box) <- Map.assocs (worldBoxes world), boxLocation box == loc] of + -- moving an empty space, so we're done + [] -> Just (fmap snd visited) + + -- moving a box + (name,box):_ -> + do loc' <- nextLoc world loc dir + guard (not (isWall loc' world)) + moveBlock' world visited loc loc' dir name box + +moveBlock' world visited loc loc' dir name box = + msum [moveTo loc', moveInto loc', moveToEat loc'] + where + moveTo loc' = moveBlock world (addVisited loc loc' visited) loc' dir + + moveInto loc' = + do (n,b) <- boxAt world loc' + let locI = enterLoc n b dir + moveBlock world (addVisited loc locI visited) locI dir + + moveToEat loc' = + do let dir' = invert dir + let locE = enterLoc name box dir' + (name', box') <- boxAt world loc' + moveBlock' world (addVisited loc loc' visited) loc' locE dir' name' box' + +enterLoc :: Char -> Box -> Movement -> Location +enterLoc name box dir = + case dir of + (-1, 0) -> Location name yhi (midpoint xlo xhi) + ( 1, 0) -> Location name ylo (midpoint xlo xhi) + ( 0,-1) -> Location name (midpoint ylo yhi) xhi + ( 0, 1) -> Location name (midpoint ylo yhi) xlo + _ -> error "enterLoc: bad direction" + where + ((ylo,xlo),(yhi,xhi)) = bounds (boxWalls box) + +boxAt :: World -> Location -> Maybe (Char, Box) +boxAt world loc = + listToMaybe [(n,b) | (n,b) <- Map.assocs (worldBoxes world), boxLocation b == loc] + +invert (dy,dx) = (-dy, -dx) + +midpoint lo hi = (hi+lo)`div`2 + +addVisited k v m = Map.insert k (Map.size m, v) m + +nextLoc world loc (dy, dx) = go Set.empty loc + where + + go visited (Location b y x) + | Just box <- Map.lookup b (worldBoxes world) + , inRange (bounds (boxWalls box)) (y+dy, x+dx) + = Just (Location b (y+dy) (x+dx)) + + go visited (Location b y x) + | Just box <- Map.lookup b (worldBoxes world) + , Set.notMember b visited + = go (Set.insert b visited) (boxLocation box) + + go _ _ = Nothing + diff --git a/parabox.cabal b/parabox.cabal new file mode 100644 index 0000000..6f2f032 --- /dev/null +++ b/parabox.cabal @@ -0,0 +1,27 @@ +cabal-version: 3.0 +name: parabox +version: 0.1.0.0 +-- synopsis: +-- description: +license: ISC +license-file: LICENSE +author: Eric Mertens +maintainer: emertens@galois.com +-- copyright: +category: Game +build-type: Simple +extra-doc-files: CHANGELOG.md +-- extra-source-files: + +common warnings + ghc-options: -Wall + +executable parabox + import: warnings + main-is: Main.hs + -- other-modules: + -- other-extensions: + ghc-options: -threaded + build-depends: base ^>=4.17.0.0, array, containers, vty + hs-source-dirs: app + default-language: Haskell2010