🐣

.gitignore

@@ -0,0 +1,2 @@
+/dist-newstyle
+cabal.project.local

CHANGELOG.md

@@ -0,0 +1,5 @@
+# Revision history for parabox
+
+## 0.1.0.0 -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.

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.

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
+

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