proper rendered borders
This commit is contained in:
Eric Mertens
parent
8202e48fa8
commit
f940ce8d75
229
app/Main.hs
229
app/Main.hs
@ -1,130 +1,13 @@
|
||||
{-# 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 unit myAttr '▓'
|
||||
else case Map.lookup (Location boxName y x) locMap of
|
||||
Nothing -> unit myAttr '░'
|
||||
Just n -> unit (boxColor (worldBoxes world Map.! n)) n
|
||||
| x <- [xlo .. xhi]
|
||||
]
|
||||
|
||||
| let ((ylo,xlo),(yhi,xhi)) = bounds (boxWalls box)
|
||||
, let myAttr = boxColor box
|
||||
, y <- [ylo .. yhi]
|
||||
, let unit a x = string a [x,x]
|
||||
]
|
||||
|
||||
renderBox' :: World -> Map Location Char -> Box -> Char -> ((Int,Int),(Int,Int)) -> Int -> Image
|
||||
renderBox' world locMap box boxName ((ylo,xlo),(yhi,xhi)) scale
|
||||
| scale == 1 = renderBox world locMap box boxName
|
||||
| otherwise =
|
||||
vertCat
|
||||
[
|
||||
horizCat
|
||||
[
|
||||
drawAt boxName box y x | x <- [xlo .. xhi]
|
||||
]
|
||||
| y <- [ylo .. yhi]
|
||||
]
|
||||
where
|
||||
unit a x =
|
||||
vertCat (replicate scale (string a (replicate (2*scale) x)))
|
||||
drawAt boxName box y x
|
||||
| let goodCoord = inRange (bounds (boxWalls box))
|
||||
, not (goodCoord (y,x))
|
||||
= unit defAttr '?'
|
||||
| otherwise
|
||||
, let myAttr = boxColor box =
|
||||
if boxWalls box ! (y,x) then unit myAttr '▓'
|
||||
else case Map.lookup (Location boxName y x) locMap of
|
||||
Nothing -> unit myAttr '░'
|
||||
Just n -> renderBox' world locMap box' n (bounds (boxWalls box')) (scale `div` boxSize box)
|
||||
where
|
||||
box' = worldBoxes world Map.! n
|
||||
|
||||
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)
|
||||
|
||||
boxSize :: Box -> Int
|
||||
boxSize box = yhi-ylo+1
|
||||
where
|
||||
((ylo,_),(yhi,_)) = bounds (boxWalls box)
|
||||
|
||||
drawNestedWorld :: World -> Image
|
||||
drawNestedWorld world = renderBox' world locMap box0 name0 bnds 49
|
||||
where
|
||||
locMap = Map.fromList [(boxLocation loc, n) | (n, loc) <- Map.toList (worldBoxes world)]
|
||||
(bnds,name0) = go 2 0 0 (worldMe world)
|
||||
box0 = worldBoxes world Map.! name0
|
||||
|
||||
go 0 y x name = (((y-1,x-1),(y+1,x+1)), name)
|
||||
go n y x name =
|
||||
case Map.lookup name (worldBoxes world) of
|
||||
Nothing -> (((y-1,x-1),(y+1,x+1)), name)
|
||||
Just box -> go (n-1) y x name'
|
||||
where
|
||||
Location name' y x = boxLocation box
|
||||
|
||||
|
||||
|
||||
|
||||
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)]
|
||||
|
||||
solid n = makeWalls (replicate n (replicate n 'x'))
|
||||
import Model
|
||||
import Rendering
|
||||
|
||||
world0 :: World
|
||||
world0 = World {
|
||||
@ -201,31 +84,6 @@ world0 = World {
|
||||
]
|
||||
}
|
||||
|
||||
-- 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 ->
|
||||
@ -250,86 +108,3 @@ loop vty (world :| history) =
|
||||
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' =
|
||||
do moveBlock world (addVisited loc loc' visited) loc' dir
|
||||
|
||||
moveInto loc' =
|
||||
do (n,b) <- boxAt world loc'
|
||||
let locI = enterLoc n b dir
|
||||
moveBlock' world visited loc locI dir name box -- beware epsilon!
|
||||
|
||||
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
|
||||
|
||||
|
||||
153
app/Model.hs
Normal file
153
app/Model.hs
Normal file
@ -0,0 +1,153 @@
|
||||
module Model where
|
||||
|
||||
import Data.Array
|
||||
import Data.Map (Map)
|
||||
import Data.Map qualified as Map
|
||||
import Graphics.Vty
|
||||
import Control.Monad
|
||||
import Data.Maybe
|
||||
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)
|
||||
|
||||
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)
|
||||
|
||||
boxSize :: Box -> Int
|
||||
boxSize box = yhi-ylo+1
|
||||
where
|
||||
((ylo,_),(yhi,_)) = bounds (boxWalls box)
|
||||
|
||||
|
||||
solid n = makeWalls (replicate n (replicate n 'x'))
|
||||
|
||||
-- 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)
|
||||
|
||||
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' =
|
||||
do moveBlock world (addVisited loc loc' visited) loc' dir
|
||||
|
||||
moveInto loc' =
|
||||
do (n,b) <- boxAt world loc'
|
||||
let locI = enterLoc n b dir
|
||||
moveBlock' world visited loc locI dir name box -- beware epsilon!
|
||||
|
||||
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
|
||||
|
||||
125
app/Rendering.hs
Normal file
125
app/Rendering.hs
Normal file
@ -0,0 +1,125 @@
|
||||
module Rendering where
|
||||
|
||||
import Data.Array
|
||||
import Data.Map (Map)
|
||||
import Data.Map qualified as Map
|
||||
import Data.Set qualified as Set
|
||||
import Graphics.Vty
|
||||
import Data.List (intersperse)
|
||||
|
||||
import Model
|
||||
|
||||
renderBox :: World -> Map Location Char -> Box -> Char -> Image
|
||||
renderBox world locMap box boxName =
|
||||
vertCat
|
||||
[
|
||||
horizCat
|
||||
[
|
||||
if boxWalls box ! (y,x) then unit myAttr '▓'
|
||||
else case Map.lookup (Location boxName y x) locMap of
|
||||
Nothing -> unit myAttr '░'
|
||||
Just n -> unit (boxColor (worldBoxes world Map.! n)) n
|
||||
| x <- [xlo .. xhi]
|
||||
]
|
||||
|
||||
| let ((ylo,xlo),(yhi,xhi)) = bounds (boxWalls box)
|
||||
, let myAttr = boxColor box
|
||||
, y <- [ylo .. yhi]
|
||||
, let unit a x = string a [x,x]
|
||||
]
|
||||
|
||||
renderBox' :: World -> Map Location Char -> Box -> Char -> Int -> Image
|
||||
renderBox' world locMap box boxName scale
|
||||
| scale == 1 = renderBox world locMap box boxName
|
||||
| otherwise =
|
||||
vertCat
|
||||
[
|
||||
horizCat
|
||||
[
|
||||
if boxWalls box ! (y,x) then unit myAttr '▓'
|
||||
else case Map.lookup (Location boxName y x) locMap of
|
||||
Nothing -> unit myAttr '░'
|
||||
Just n -> renderBox' world locMap box' n (scale `div` boxSize box)
|
||||
where
|
||||
box' = worldBoxes world Map.! n
|
||||
| x <- [xlo .. xhi]
|
||||
]
|
||||
| let ((ylo,xlo),(yhi,xhi)) = bounds (boxWalls box)
|
||||
, let myAttr = boxColor box
|
||||
, y <- [ylo .. yhi]
|
||||
]
|
||||
where
|
||||
unit a x =
|
||||
vertCat (replicate scale (string a (replicate (2*scale) x)))
|
||||
|
||||
|
||||
drawNestedWorld :: World -> Image
|
||||
drawNestedWorld world =
|
||||
-- (3*49) + 49 + (3*49)
|
||||
cropTop (49 + 2*border) $
|
||||
cropLeft (2*(49 + 2*border)) $
|
||||
cropBottom (2*49 + border) $
|
||||
cropRight (2*(2*49 + border)) $
|
||||
vertCat [
|
||||
horizCat [
|
||||
case stackedLoc world (Location name1 y x) of
|
||||
Nothing -> unit (withForeColor defAttr black) '?'
|
||||
Just (Location n y x) ->
|
||||
let box = worldBoxes world Map.! n
|
||||
myAttr = boxColor box in
|
||||
if boxWalls box ! (y,x) then unit myAttr '▓'
|
||||
else case Map.lookup (Location n y x) locMap of
|
||||
Nothing -> unit myAttr '░'
|
||||
Just n -> renderBox' world locMap box' n (49 `div` boxSize box)
|
||||
where
|
||||
box' = worldBoxes world Map.! n
|
||||
| x <- [x1-1 .. x1+1]
|
||||
]
|
||||
| y <- [y1-1 .. y1+1]
|
||||
]
|
||||
|
||||
where
|
||||
border = 20
|
||||
unit a x =
|
||||
vertCat (replicate 49 (string a (replicate (2*49) x)))
|
||||
locMap = Map.fromList [(boxLocation loc, n) | (n, loc) <- Map.toList (worldBoxes world)]
|
||||
|
||||
-- name1 is the box the player is standing in
|
||||
Location name0 _ _ = boxLocation (worldBoxes world Map.! worldMe world)
|
||||
|
||||
Location name1 y1 x1 = boxLocation (worldBoxes world Map.! name0)
|
||||
|
||||
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)]
|
||||
|
||||
|
||||
stackedLoc :: World -> Location -> Maybe Location
|
||||
stackedLoc world = go Set.empty
|
||||
where
|
||||
go visited loc | Set.member loc visited = Nothing
|
||||
|
||||
go visited loc@(Location b y x) =
|
||||
do box <- Map.lookup b (worldBoxes world)
|
||||
let bnds@((ylo,xlo),(yhi,xhi)) = bounds (boxWalls box)
|
||||
if inRange bnds (y, x)
|
||||
then Just loc
|
||||
else
|
||||
let dx = overflow (xlo,xhi) x
|
||||
dy = overflow (ylo,yhi) y
|
||||
Location parent py px = boxLocation box
|
||||
in go (Set.insert loc visited) (Location parent (py+dy) (px+dx))
|
||||
|
||||
|
||||
overflow :: (Int, Int) -> Int -> Int
|
||||
overflow (lo,hi) x
|
||||
| x < lo = x - lo
|
||||
| x > hi = x - hi
|
||||
| otherwise = 0
|
||||
@ -19,8 +19,10 @@ common warnings
|
||||
executable parabox
|
||||
import: warnings
|
||||
main-is: Main.hs
|
||||
other-modules: Rendering, Model
|
||||
-- other-modules:
|
||||
-- other-extensions:
|
||||
default-extensions: ImportQualifiedPost, BlockArguments, LambdaCase
|
||||
|
||||
ghc-options: -threaded
|
||||
build-depends: base ^>=4.17.0.0, array, containers, vty
|
||||
hs-source-dirs: app
|
||||
|
||||
Loading…
Reference in New Issue
Block a user