🐣
This commit is contained in:
Eric Mertens
commit
48af4f917c
2
.gitignore
vendored
Normal file
2
.gitignore
vendored
Normal file
@ -0,0 +1,2 @@
|
|||||||
|
/dist-newstyle
|
||||||
|
cabal.project.local
|
||||||
5
CHANGELOG.md
Normal file
5
CHANGELOG.md
Normal file
@ -0,0 +1,5 @@
|
|||||||
|
# Revision history for parabox
|
||||||
|
|
||||||
|
## 0.1.0.0 -- YYYY-mm-dd
|
||||||
|
|
||||||
|
* First version. Released on an unsuspecting world.
|
||||||
13
LICENSE
Normal file
13
LICENSE
Normal file
@ -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.
|
||||||
261
app/Main.hs
Normal file
261
app/Main.hs
Normal file
@ -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
|
||||||
|
|
||||||
27
parabox.cabal
Normal file
27
parabox.cabal
Normal file
@ -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
|
||||||
Loading…
Reference in New Issue
Block a user