add some level selection
This commit is contained in:
parent
f01d1f643c
commit
f9d9e332eb
92
app/Main.hs
92
app/Main.hs
@ -5,12 +5,16 @@ import Graphics.Vty
|
||||
import Control.Exception
|
||||
import Data.List.NonEmpty (NonEmpty(..))
|
||||
import Data.List.NonEmpty qualified as NonEmpty
|
||||
import Data.Set qualified as Set
|
||||
import System.Environment
|
||||
|
||||
import Model
|
||||
import Rendering
|
||||
|
||||
world0 :: World
|
||||
world0 = World {
|
||||
worldButtons = Set.empty,
|
||||
worldHome = Location '2' 0 0,
|
||||
worldMe = 'b',
|
||||
worldBoxes = Map.fromList
|
||||
[('1', Box {
|
||||
@ -154,10 +158,12 @@ world0 = World {
|
||||
|
||||
main :: IO ()
|
||||
main =
|
||||
bracket (mkVty =<< userConfig) shutdown \vty ->
|
||||
do
|
||||
loop vty (pure clone11)
|
||||
pure ()
|
||||
do args <- getArgs
|
||||
let name = case args of x:_ -> x; [] -> ""
|
||||
bracket (mkVty =<< userConfig) shutdown \vty ->
|
||||
do
|
||||
loop vty (pure (pickWorld name))
|
||||
pure ()
|
||||
|
||||
loop :: Vty -> NonEmpty World -> IO ()
|
||||
loop vty (world :| history) =
|
||||
@ -170,6 +176,7 @@ loop vty (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 'r' -> loop vty (pure (NonEmpty.last (world :| history)))
|
||||
KChar 'z'
|
||||
| Just worlds <- NonEmpty.nonEmpty history ->
|
||||
loop vty worlds
|
||||
@ -177,6 +184,14 @@ loop vty (world :| history) =
|
||||
_ -> loop vty (world :| history)
|
||||
_ -> loop vty (world :| history)
|
||||
|
||||
pickWorld :: String -> World
|
||||
pickWorld "world0" = world0
|
||||
pickWorld "small" = smallWorld
|
||||
pickWorld "center8" = center8
|
||||
pickWorld "center13" = center13
|
||||
pickWorld "clone11" = clone11
|
||||
pickWorld _ = transfer14
|
||||
|
||||
smallWorld :: World
|
||||
smallWorld =
|
||||
World
|
||||
@ -221,6 +236,8 @@ smallWorld =
|
||||
(Original (solid 9))
|
||||
(withForeColor defAttr red))
|
||||
]) 'b'
|
||||
Set.empty
|
||||
(Location 'b' 0 0)
|
||||
|
||||
center8 :: World
|
||||
center8 =
|
||||
@ -266,6 +283,8 @@ center8 =
|
||||
(Original (solid 9))
|
||||
(withForeColor defAttr red))
|
||||
]) 'b'
|
||||
Set.empty
|
||||
(Location 'a' 3 2)
|
||||
|
||||
center13 :: World
|
||||
center13 =
|
||||
@ -311,6 +330,8 @@ center13 =
|
||||
(Original (solid 9))
|
||||
(withForeColor defAttr red))
|
||||
]) 'b'
|
||||
Set.empty
|
||||
(Location 'a' 2 0)
|
||||
|
||||
|
||||
clone11 :: World
|
||||
@ -341,4 +362,65 @@ clone11 =
|
||||
(Location 'a' 0 (-2))
|
||||
(Original (solid 9))
|
||||
(withForeColor defAttr red))
|
||||
]) 'b'
|
||||
])
|
||||
'b'
|
||||
(Set.fromList [Location 'a' (-1) (-3), Location 'a' (-2) (-3)])
|
||||
(Location 'a' (-3) (-3))
|
||||
|
||||
transfer14 :: World
|
||||
transfer14 =
|
||||
World
|
||||
(Map.fromList
|
||||
[('a',
|
||||
Box (Location 'a' 1 1)
|
||||
(Original (makeWalls [
|
||||
" ",
|
||||
" ",
|
||||
" ",
|
||||
" ",
|
||||
" ▓ ",
|
||||
" ",
|
||||
" ",
|
||||
" ",
|
||||
" "
|
||||
]))
|
||||
(withForeColor defAttr cyan)),
|
||||
('g',
|
||||
Box
|
||||
(Location 'a' (-1) (-1))
|
||||
(Original (makeWalls [
|
||||
" ▓▓▓ ",
|
||||
" ▓ ▓ ",
|
||||
" ",
|
||||
" ▓ ",
|
||||
"▓▓ ▓ ▓▓",
|
||||
" ▓ ",
|
||||
" ",
|
||||
" ",
|
||||
" ▓ "
|
||||
]))
|
||||
(withForeColor defAttr green)),
|
||||
('x',
|
||||
Box
|
||||
(Location 'g' 3 (-3))
|
||||
(Original (makeWalls [
|
||||
" ",
|
||||
" ",
|
||||
" ",
|
||||
" ",
|
||||
" ",
|
||||
" ",
|
||||
" ",
|
||||
" ",
|
||||
" "
|
||||
]))
|
||||
(withForeColor defAttr magenta)),
|
||||
('b',
|
||||
Box
|
||||
(Location 'a' 1 (-1))
|
||||
(Original (solid 9))
|
||||
(withForeColor defAttr red))
|
||||
])
|
||||
'b'
|
||||
(Set.fromList [Location 'g' (-2) 0])
|
||||
(Location 'g' (-3) 0)
|
||||
|
||||
@ -7,7 +7,7 @@ import Graphics.Vty
|
||||
import Control.Monad
|
||||
import Data.Maybe
|
||||
import Data.Set qualified as Set
|
||||
import Debug.Trace
|
||||
import Data.Set (Set)
|
||||
|
||||
type Coord = (Int, Int)
|
||||
|
||||
@ -34,7 +34,9 @@ data Location = Location Char Int Int
|
||||
|
||||
data World = World {
|
||||
worldBoxes :: Map Char Box,
|
||||
worldMe :: Char
|
||||
worldMe :: Char,
|
||||
worldButtons :: Set Location,
|
||||
worldHome :: Location
|
||||
}
|
||||
deriving (Show, Read, Eq)
|
||||
|
||||
|
||||
@ -12,25 +12,45 @@ unit :: Attr -> Int -> Char -> Image
|
||||
unit a scale x =
|
||||
vertCat (replicate scale (string a (replicate (2*scale) x)))
|
||||
|
||||
button :: Attr -> Int -> Image
|
||||
button a 1 = string a "[]"
|
||||
button a n = vertCat $
|
||||
string a ('┌' : replicate (2*n-2) '─' ++ "┐") :
|
||||
replicate (n-2) (string a ('│' : replicate (2*n-2) '░' ++ "│")) ++
|
||||
[string a ('└' : replicate (2*n-2) '─' ++ "┘")]
|
||||
|
||||
home :: Attr -> Int -> Image
|
||||
home a 1 = string a "<>"
|
||||
home a n = vertCat $
|
||||
string a ('╔' : replicate (2*n-2) '═' ++ "╗") :
|
||||
replicate (n-2) (string a ('║' : replicate (2*n-2) '░' ++ "║")) ++
|
||||
[string a ('╚' : replicate (2*n-2) '═' ++ "╝")]
|
||||
|
||||
|
||||
|
||||
renderCell :: World -> Map Location Char -> Char -> Box -> Int -> Int -> Int -> Image
|
||||
renderCell world locMap name box y x scale =
|
||||
if boxWalls world box ! (y,x) then unit (boxColor box) scale wallChar
|
||||
else case Map.lookup (Location name' y x) locMap of
|
||||
Nothing -> unit (boxColor box) scale '░'
|
||||
Just n ->
|
||||
if scale == 1
|
||||
then unit (boxColor (worldBoxes world Map.! n)) scale n
|
||||
else renderBox world locMap (worldBoxes world Map.! n) n
|
||||
(scale `div` boxSize world box)
|
||||
Nothing
|
||||
| Set.member loc (worldButtons world) -> button (boxColor box) scale
|
||||
| loc == worldHome world -> home (boxColor box) scale
|
||||
| otherwise -> unit (boxColor box) scale '░'
|
||||
where
|
||||
name' =
|
||||
case boxType box of
|
||||
Original{} -> name
|
||||
Link c -> c
|
||||
wallChar =
|
||||
case boxType box of
|
||||
Original{} -> '▓'
|
||||
Link{} -> '▒'
|
||||
loc = Location name' y x
|
||||
name' =
|
||||
case boxType box of
|
||||
Original{} -> name
|
||||
Link c -> c
|
||||
wallChar =
|
||||
case boxType box of
|
||||
Original{} -> '▓'
|
||||
Link{} -> '▒'
|
||||
|
||||
renderBox :: World -> Map Location Char -> Box -> Char -> Int -> Image
|
||||
renderBox world locMap box name scale =
|
||||
|
||||
Loading…
Reference in New Issue
Block a user