big ?
This commit is contained in:
Eric Mertens
parent
84f74366bb
commit
a67bbea3cb
|
|
@ -19,6 +19,12 @@ letters = Map.fromList
|
|||
," "
|
||||
," "
|
||||
," "]),
|
||||
('?',
|
||||
["██████ "
|
||||
," ██"
|
||||
," ▄███ "
|
||||
," ▀▀ "
|
||||
," ██ "]),
|
||||
('A',
|
||||
[" █████ "
|
||||
,"██ ██"
|
||||
|
|
|
|||
16
app/Model.hs
16
app/Model.hs
|
|
@ -23,8 +23,8 @@ boxWalls :: World -> Box -> Array Coord Bool
|
|||
boxWalls world box =
|
||||
case boxType box of
|
||||
Original walls -> walls
|
||||
Link c -> boxWalls world (worldBoxes world Map.! c)
|
||||
Infinity c -> boxWalls world (worldBoxes world Map.! c)
|
||||
Link c -> boxWalls world (boxIx world c)
|
||||
Infinity c -> boxWalls world (boxIx world c)
|
||||
Epsilon _ walls -> walls
|
||||
|
||||
data BoxType
|
||||
|
|
@ -50,9 +50,9 @@ data World = World {
|
|||
winCondition :: World -> Bool
|
||||
winCondition world =
|
||||
Set.isSubsetOf (worldButtons world) coverage &&
|
||||
Just (worldHome world) == boxLocation (worldBoxes world Map.! worldMe world)
|
||||
Just (worldHome world) == boxLocation (boxIx world (worldMe world))
|
||||
where
|
||||
coverage = Set.fromList $ mapMaybe boxLocation $ Map.elems (worldBoxes world)
|
||||
coverage = Set.fromList (mapMaybe boxLocation (Map.elems (worldBoxes world)))
|
||||
|
||||
|
||||
boxSize :: World -> Box -> Int
|
||||
|
|
@ -72,8 +72,7 @@ move world dir =
|
|||
world { worldBoxes = Map.mergeWithKey (\_ a b -> Just (f a b)) id (const Map.empty) (worldBoxes world) changes}
|
||||
|
||||
myLocation :: World -> Maybe Location
|
||||
myLocation world =
|
||||
boxLocation (worldBoxes world Map.! worldMe world)
|
||||
myLocation world = boxLocation (boxIx world (worldMe world))
|
||||
|
||||
isWall :: World -> Location -> Bool
|
||||
isWall world (Location n y x) =
|
||||
|
|
@ -140,7 +139,7 @@ moveBlock' world visited loc loc' dir name box enters offset =
|
|||
|
||||
moveEpsilon =
|
||||
do epsilon <- findEpsilon world (locName loc')
|
||||
let eBox = worldBoxes world Map.! epsilon
|
||||
let eBox = boxIx world epsilon
|
||||
(locI, offset') <- enterLoc world epsilon eBox dir offset
|
||||
moveBlock' world visited loc locI dir name box (Set.insert locI enters) offset'
|
||||
|
||||
|
|
@ -177,6 +176,9 @@ boxAt :: World -> Location -> Maybe (Char, Box)
|
|||
boxAt world loc =
|
||||
listToMaybe [(n,b) | (n,b) <- Map.assocs (worldBoxes world), boxLocation b == Just loc]
|
||||
|
||||
boxIx :: World -> Char -> Box
|
||||
boxIx world name = worldBoxes world Map.! name
|
||||
|
||||
invert :: Movement -> Movement
|
||||
invert (dy,dx) = (-dy, -dx)
|
||||
|
||||
|
|
|
|||
|
|
@ -1,14 +1,14 @@
|
|||
{-# Language ViewPatterns #-}
|
||||
module Parser where
|
||||
module Parser (parse) where
|
||||
|
||||
import Model
|
||||
import Graphics.Vty.Attributes
|
||||
import Control.Applicative
|
||||
import Control.Monad
|
||||
import Data.Array (Array, listArray)
|
||||
import Data.Map qualified as Map
|
||||
import Data.Set qualified as Set
|
||||
import Graphics.Vty.Attributes
|
||||
import Text.ParserCombinators.ReadP hiding (many)
|
||||
import Control.Applicative
|
||||
import Control.Monad
|
||||
|
||||
import Model
|
||||
|
||||
parse :: String -> World
|
||||
parse str =
|
||||
|
|
@ -17,10 +17,7 @@ parse str =
|
|||
(((p,h,w),bs),_):_ ->
|
||||
do let m = Map.fromListWith (++) [(k,[v]) | (_,_,kvs) <- bs, (k,v) <- kvs]
|
||||
World
|
||||
(Map.fromList [
|
||||
(n, b { boxLocation = fmap head (Map.lookup n m)})
|
||||
| (n,b,_) <- bs
|
||||
])
|
||||
(Map.fromList [(n, b { boxLocation = head <$> Map.lookup n m }) | (n,b,_) <- bs])
|
||||
p
|
||||
(Set.fromList (Map.findWithDefault [] '-' m))
|
||||
(head (m Map.! '='))
|
||||
|
|
@ -45,9 +42,9 @@ parseBoring :: ReadP Bool
|
|||
parseBoring =
|
||||
do t <- token
|
||||
case t of
|
||||
"boring" -> pure True
|
||||
"boring" -> pure True
|
||||
"interesting" -> pure False
|
||||
_ -> empty
|
||||
_ -> empty
|
||||
|
||||
parseBlock :: ReadP (Char, Box, [(Char, Location)])
|
||||
parseBlock =
|
||||
|
|
@ -68,13 +65,13 @@ parseBlock =
|
|||
[target] <- token
|
||||
color <- parseColor
|
||||
_ <- char '\n'
|
||||
pure (name, Box undefined (Link target) color True, [])
|
||||
pure (name, Box Nothing (Link target) color True, [])
|
||||
"infinity" ->
|
||||
do [name] <- token
|
||||
[target] <- token
|
||||
color <- parseColor
|
||||
_ <- char '\n'
|
||||
pure (name, Box undefined (Infinity target) color True,[])
|
||||
pure (name, Box Nothing (Infinity target) color True,[])
|
||||
"epsilon" ->
|
||||
do [name] <- token
|
||||
[target] <- token
|
||||
|
|
@ -83,7 +80,7 @@ parseBlock =
|
|||
_ <- char '\n'
|
||||
xs1 <- parseWalls
|
||||
let locs = findLocs name xs1
|
||||
let b = Box undefined (Epsilon target (walls xs1)) color False
|
||||
let b = Box Nothing (Epsilon target (walls xs1)) color False
|
||||
pure (name, b, locs)
|
||||
_ -> empty
|
||||
|
||||
|
|
|
|||
125
app/Rendering.hs
125
app/Rendering.hs
|
|
@ -7,6 +7,8 @@ import Data.Map qualified as Map
|
|||
import Data.Set qualified as Set
|
||||
import Data.List (intersperse, group)
|
||||
import Graphics.Vty
|
||||
|
||||
import BigFont
|
||||
import Model
|
||||
|
||||
border :: Int
|
||||
|
|
@ -17,23 +19,20 @@ unit a h w c =
|
|||
vertCat (replicate h (string a (replicate w c)))
|
||||
|
||||
drawBox :: Attr -> Int {- ^ width -} -> Int {- ^ height -} -> Image
|
||||
drawBox a 2 1 = string a "[]"
|
||||
drawBox a w 1 = string a ("[" ++ replicate (w-2) '-' ++ "]")
|
||||
drawBox a w h = vertCat $
|
||||
drawBox a 1 w = string a ("[" ++ replicate (w-2) '-' ++ "]")
|
||||
drawBox a h w = vertCat $
|
||||
string a ('┌' : replicate (w-2) '─' ++ "┐") :
|
||||
replicate (h-2) (string a ('│' : replicate (w-2) ' ' ++ "│")) ++
|
||||
[string a ('└' : replicate (w-2) '─' ++ "┘")]
|
||||
|
||||
button :: Attr -> Int -> Int -> Image
|
||||
button a 1 2 = string a "[]"
|
||||
button a 1 n = string a ("[" ++ replicate (n-2) '-' ++ "]")
|
||||
button a 1 w = string a ("[" ++ replicate (w-2) '-' ++ "]")
|
||||
button a h w = vertCat $
|
||||
string a ('┌' : replicate (w-2) '─' ++ "┐") :
|
||||
replicate (h-2) (string a ('│' : replicate (w-2) '░' ++ "│")) ++
|
||||
[string a ('└' : replicate (w-2) '─' ++ "┘")]
|
||||
|
||||
home :: Attr -> Int -> Int -> Image
|
||||
home a 1 2 = string a "<>"
|
||||
home a 1 w = string a ("<" ++ replicate (w-2) '=' ++ ">")
|
||||
home a h w = vertCat $
|
||||
string a ('╔' : replicate (w-2) '═' ++ "╗") :
|
||||
|
|
@ -41,53 +40,55 @@ home a h w = vertCat $
|
|||
[string a ('╚' : replicate (w-2) '═' ++ "╝")]
|
||||
|
||||
renderCell :: World -> Map Location Char -> Char -> Box -> Int -> Int -> Int -> Int -> Image
|
||||
renderCell world locMap name box y x h w =
|
||||
if boxWalls world box ! (y,x) then unit (boxColor box) h w wallChar
|
||||
else case Map.lookup (Location name' y x) locMap of
|
||||
Just n ->
|
||||
let box' = worldBoxes world Map.! n
|
||||
in if h < boxSize world box'
|
||||
then unit (boxColor box') h w n
|
||||
else renderBox world locMap box' n
|
||||
h w
|
||||
Nothing
|
||||
| Set.member loc (worldButtons world) -> button (boxColor box) h w
|
||||
| loc == worldHome world -> home (boxColor box) h w
|
||||
| otherwise -> unit (boxColor box) h w floorChar
|
||||
renderCell world locMap name box y x h w
|
||||
|
||||
| boxWalls world box ! (y,x) = unit (boxColor box) h w wallChar
|
||||
|
||||
| Just n <- Map.lookup (Location name' y x) locMap
|
||||
, let box' = boxIx world n
|
||||
= if h < boxSize world box'
|
||||
then unit (boxColor box') h w n
|
||||
else renderBox world locMap box' n h w
|
||||
|
||||
| Set.member loc (worldButtons world) = button (boxColor box) h w
|
||||
|
||||
| loc == worldHome world = home (boxColor box) h w
|
||||
|
||||
| otherwise = unit (boxColor box) h w floorChar
|
||||
where
|
||||
loc = Location name' y x
|
||||
name' = contentName world name box
|
||||
wallChar =
|
||||
case boxType box of
|
||||
Original{} -> '▓'
|
||||
Link{} -> '▒'
|
||||
Original {} -> '▓'
|
||||
Link {} -> '▒'
|
||||
Infinity {} -> '▓'
|
||||
Epsilon {} -> '▓'
|
||||
Epsilon {} -> '▓'
|
||||
floorChar =
|
||||
case boxType box of
|
||||
Original{} -> '░'
|
||||
Link{} -> '·'
|
||||
Original {} -> '░'
|
||||
Link {} -> '·'
|
||||
Infinity {} -> '∞'
|
||||
Epsilon {} -> 'ε'
|
||||
Epsilon {} -> 'ε'
|
||||
|
||||
contentName :: World -> Char -> Box -> Char
|
||||
contentName world name box =
|
||||
case boxType box of
|
||||
Original{} -> name
|
||||
Link c -> c
|
||||
Infinity c -> contentName world c (worldBoxes world Map.! c)
|
||||
Epsilon{} -> name
|
||||
Epsilon{} -> name
|
||||
Link c -> c
|
||||
Infinity c -> contentName world c (boxIx world c)
|
||||
|
||||
renderBox :: World -> Map Location Char -> Box -> Char -> Int -> Int -> Image
|
||||
renderBox world locMap box name boxh boxw =
|
||||
vertCat [
|
||||
horizCat [
|
||||
renderCell world locMap name box y x cellh cellw
|
||||
| (x,cellw) <- zip [xlo .. xhi] (divisions boxWidth boxw)
|
||||
]
|
||||
| (y,cellh) <- zip [ylo .. yhi] (divisions boxHeight boxh)
|
||||
]
|
||||
| (x,cellw) <- zip [xlo .. xhi] xdivs ]
|
||||
| (y,cellh) <- zip [ylo .. yhi] ydivs ]
|
||||
where
|
||||
ydivs = divisions boxHeight boxh
|
||||
xdivs = divisions boxWidth boxw
|
||||
((ylo,xlo),(yhi,xhi)) = bounds (boxWalls world box)
|
||||
boxWidth = xhi - xlo + 1
|
||||
boxHeight = yhi - ylo + 1
|
||||
|
|
@ -105,15 +106,19 @@ render flat world = picForLayers $
|
|||
string defAttr "╚███╔███╔╝██║██║ ╚████║██║ ╚████║███████╗██║ ██║" <->
|
||||
string defAttr " ╚══╝╚══╝ ╚═╝╚═╝ ╚═══╝╚═╝ ╚═══╝╚══════╝╚═╝ ╚═╝"
|
||||
| winCondition world ] ++
|
||||
[ pad 94 7 0 0 $
|
||||
vertCat (map (string defAttr) (bigText "VOIDED"))
|
||||
| isNothing (boxLocation (boxIx world (worldMe world))) ] ++
|
||||
(if flat then renderFlat locMap world else []) ++
|
||||
[drawNestedWorld locMap world]
|
||||
where
|
||||
locMap = Map.fromList [(loc, n) | (n, box) <- Map.toList (worldBoxes world), loc <- maybeToList (boxLocation box)]
|
||||
locMap = Map.fromList [(loc, n) | (n, box) <- Map.toList (worldBoxes world)
|
||||
, loc <- maybeToList (boxLocation box)]
|
||||
|
||||
renderFlat :: Map Location Char -> World -> [Image]
|
||||
renderFlat locMap world =
|
||||
[ pad offset 0 0 0 baseImage
|
||||
, pad offset 0 0 0 $ drawBox borderAttr (imageWidth baseImage) (imageHeight baseImage)
|
||||
, pad offset 0 0 0 $ drawBox borderAttr (imageHeight baseImage) (imageWidth baseImage)
|
||||
]
|
||||
where
|
||||
borderAttr = defAttr `withForeColor` white `withBackColor` black
|
||||
|
|
@ -140,28 +145,47 @@ drawNestedWorld locMap world =
|
|||
[
|
||||
case myLocation world of
|
||||
Nothing
|
||||
| dx==0 && dy==0 -> renderBox world locMap (worldBoxes world Map.! worldMe world) (worldMe world) h w
|
||||
| dx==0 && dy==0 -> renderBox world locMap (boxIx world (worldMe world)) (worldMe world) h w
|
||||
| otherwise -> infinityImage
|
||||
Just (Location name0 _ _) ->
|
||||
case boxLocation (worldBoxes world Map.! name0) of
|
||||
case boxLocation (boxIx world name0) of
|
||||
Nothing
|
||||
| dx==0 && dy==0 -> renderBox world locMap (worldBoxes world Map.! name0) name0 h w
|
||||
| dx==0 && dy==0 -> renderBox world locMap (boxIx world name0) name0 h w
|
||||
| otherwise -> infinityImage
|
||||
Just (Location name1 y1 x1) ->
|
||||
case stackedLoc world locMap (Location name1 (y1+dy) (x1+dx)) of
|
||||
Nothing -> infinityImage
|
||||
Just (Location n y x) ->
|
||||
let box = worldBoxes world Map.! n in
|
||||
renderCell world locMap n box y x h w
|
||||
renderCell world locMap n (boxIx world n) y x h w
|
||||
| dx <- [-1 .. 1]
|
||||
]
|
||||
| dy <- [-1 .. 1]
|
||||
]
|
||||
where
|
||||
infinityImage = unit (withForeColor defAttr black) h w '?'
|
||||
infinityImage = makeInfinity h w
|
||||
h = worldHeight world
|
||||
w = worldWidth world
|
||||
|
||||
makeInfinity :: Int -> Int -> Image
|
||||
makeInfinity h w = result
|
||||
where
|
||||
attr = defAttr `withForeColor` black
|
||||
single = vertCat (map (string attr) (bigText "?"))
|
||||
|
||||
rowN = (w+1) `div` (imageWidth single + 1)
|
||||
rowTotalGap = w - rowN * imageWidth single
|
||||
rowGaps = divisions (rowN-1) rowTotalGap
|
||||
|
||||
row = foldr mkRow single rowGaps
|
||||
mkRow gap rest = single <|> charFill attr ' ' gap 1 <|> rest
|
||||
|
||||
colN = (h+1) `div` (imageHeight single + 1)
|
||||
colTotalGap = h - colN * imageHeight single
|
||||
colGaps = divisions (colN-1) colTotalGap
|
||||
|
||||
result = foldr mkCol row colGaps
|
||||
mkCol gap rest = row <-> charFill attr ' ' 1 gap <-> rest
|
||||
|
||||
stackedLoc :: World -> Map Location Char -> Location -> Maybe Location
|
||||
stackedLoc world locMap = go Set.empty
|
||||
where
|
||||
|
|
@ -187,20 +211,20 @@ overflow (lo,hi) x
|
|||
| x > hi = x - hi
|
||||
| otherwise = 0
|
||||
|
||||
fixup :: World ->
|
||||
Map Location Char ->
|
||||
Int ->
|
||||
Int ->
|
||||
Int ->
|
||||
Int ->
|
||||
Location ->
|
||||
fixup :: World ->
|
||||
Map Location Char ->
|
||||
Int ->
|
||||
Int ->
|
||||
Int ->
|
||||
Int ->
|
||||
Location ->
|
||||
Location
|
||||
fixup world locMap dy dx py px loc =
|
||||
case Map.lookup loc locMap of
|
||||
Nothing -> loc
|
||||
Just name -> Location name (fixup1 ylo yhi dy py) (fixup1 xlo xhi dx px)
|
||||
where
|
||||
((ylo,xlo),(yhi,xhi)) = bounds (boxWalls world (worldBoxes world Map.! name))
|
||||
((ylo,xlo),(yhi,xhi)) = bounds (boxWalls world (boxIx world name))
|
||||
|
||||
fixup1 :: Int -> Int -> Int -> Int -> Int
|
||||
fixup1 _ _ 0 i = i
|
||||
|
|
@ -208,7 +232,10 @@ fixup1 _ hi (-1) _ = hi
|
|||
fixup1 lo _ 1 _ = lo
|
||||
fixup1 _ _ _ _ = error "fixup1: bad delta"
|
||||
|
||||
divisions :: Int -> Int -> [Int]
|
||||
divisions ::
|
||||
Int {- ^ result length -} ->
|
||||
Int {- ^ result sum -} ->
|
||||
[Int]
|
||||
divisions divs size =
|
||||
map length $ group
|
||||
[ round (
|
||||
|
|
|
|||
|
|
@ -1,16 +1,14 @@
|
|||
player p
|
||||
player p height 80 width 160
|
||||
block p magenta interesting
|
||||
|
||||
|
||||
p ▓
|
||||
|
||||
1 2
|
||||
|
||||
c
|
||||
|
||||
▓ ▓
|
||||
p
|
||||
1 2
|
||||
c
|
||||
block c green interesting
|
||||
▓▓▓
|
||||
=▓
|
||||
▓▓▓
|
||||
▓=▓
|
||||
▓ ▓
|
||||
block 1 blue boring
|
||||
▓
|
||||
block 2 blue boring
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user