diff --git a/app/Main.hs b/app/Main.hs index e60387e..173beca 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -39,18 +39,45 @@ renderBox world locMap box boxName = [ horizCat [ - if boxWalls box ! (y,x) then char myAttr '▓' + if boxWalls box ! (y,x) then unit myAttr '▓' else case Map.lookup (Location boxName y x) locMap of - Nothing -> char myAttr '░' - Just n -> char (boxColor (worldBoxes world Map.! n)) n + 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 + [ + if not (inRange (bounds (boxWalls box)) (y,x)) then unit defAttr '?' else + 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 + | x <- [xlo .. xhi] + ] + + | let myAttr = boxColor box + , y <- [ylo .. yhi] + ] + where + unit a x = + vertCat (replicate scale (string a (replicate (2*scale) x))) + + makeWalls :: [String] -> Array Coord Bool makeWalls rows = listArray ((ylo,xlo),(yhi,xhi)) (map (' '/=) (concat rows)) where @@ -61,6 +88,29 @@ makeWalls rows = listArray ((ylo,xlo),(yhi,xhi)) (map (' '/=) (concat rows)) 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 $ @@ -72,6 +122,8 @@ drawWorld world = where locMap = Map.fromList [(boxLocation loc, n) | (n, loc) <- Map.toList (worldBoxes world)] +solid n = makeWalls (replicate n (replicate n 'x')) + world0 :: World world0 = World { worldMe = 'b', @@ -80,49 +132,43 @@ world0 = World { 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 [ - "▓ ▓", - " ", - "▓ ▓" - ] + boxWalls = solid 7 }), ('x', Box { boxColor = withForeColor defAttr yellow, boxLocation = Location '1' 0 (-1), - boxWalls = makeWalls ["▓"] + boxWalls = solid 7 }), ('y', Box { boxColor = withForeColor defAttr magenta, boxLocation = Location '1' 0 (-2), - boxWalls = makeWalls ["▓"] + boxWalls = solid 7 }) ] @@ -162,7 +208,7 @@ main = loop :: Vty -> NonEmpty World -> IO () loop vty (world :| history) = - do update vty (picForImage (drawWorld world)) + do update vty (picForImage (drawNestedWorld world)) ev <- nextEvent vty case ev of EvKey key _modifier -> @@ -204,21 +250,24 @@ moveBlock world visited loc dir = -- 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 + moveTo loc' = + do guard (not (isWall loc' world)) + moveBlock world (addVisited loc loc' visited) loc' dir moveInto loc' = - do (n,b) <- boxAt world loc' + do guard (not (isWall loc' world)) + (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 + do guard (not (isWall loc' world)) + 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'