diff --git a/app/Main.hs b/app/Main.hs index ae8f84d..8e522ad 100644 --- a/app/Main.hs +++ b/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 - diff --git a/app/Model.hs b/app/Model.hs new file mode 100644 index 0000000..3aa0fea --- /dev/null +++ b/app/Model.hs @@ -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 + diff --git a/app/Rendering.hs b/app/Rendering.hs new file mode 100644 index 0000000..e4b78c3 --- /dev/null +++ b/app/Rendering.hs @@ -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 diff --git a/parabox.cabal b/parabox.cabal index 6f2f032..0033832 100644 --- a/parabox.cabal +++ b/parabox.cabal @@ -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