From b63b11659bef9c0ab1c2057634545cc9fdab1509 Mon Sep 17 00:00:00 2001 From: Eric Mertens Date: Fri, 2 Dec 2022 18:49:26 -0800 Subject: [PATCH] subpixel into --- app/Main.hs | 88 +++++++++++++++++++++++++++++++++++++++++++++------- app/Model.hs | 66 ++++++++++++++++++++++----------------- 2 files changed, 115 insertions(+), 39 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index e610cba..dd7591b 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -34,8 +34,8 @@ world0 = World { boxType = Original $ makeWalls [ "▓ ▓▓ ▓▓ ▓", " ", - "▓ ▓", - "▓ ▓", + " ▓", + " ▓", " ", "▓ ▓", "▓ ▓", @@ -53,11 +53,11 @@ world0 = World { boxLocation = Location '2' 1 1, boxType = Original $ makeWalls [ "▓▓▓▓▓▓▓▓▓", - "▓▓▓▓▓▓▓▓▓", - "▓▓▓▓▓▓▓▓▓", - "▓▓ ▓▓▓▓", - "▓▓ ▓▓▓▓", - "▓▓▓▓ ▓▓▓▓", + " ", + "▓▓▓▓▓▓▓▓ ", + "▓▓ ▓▓▓ ", + "▓▓ ▓▓▓ ", + "▓▓▓▓ ▓▓▓ ", "▓▓ ▓▓▓▓", "▓▓ ▓▓▓▓", "▓▓▓▓ ▓▓▓▓" @@ -85,9 +85,9 @@ world0 = World { "▓▓▓▓▓▓▓▓▓", "▓ ▓", "▓ ▓", + "▓ ▓ ▓ ▓", + "▓ ▓", "▓ ▓", - " ", - "▓ ▓▓", "▓ ▓", "▓ ▓", "▓▓▓▓▓▓▓▓▓" @@ -96,12 +96,33 @@ world0 = World { ('x', Box { boxColor = withForeColor defAttr yellow, boxLocation = Location '1' 0 (-1), - boxType = Original $ solid 9 + boxType = Original $ + makeWalls [ + "▓▓ ▓ ", + " ", + " ▓ ▓▓▓ ", + " ▓ ", + "▓ ▓▓▓▓", + " ▓▓▓ ", + " ▓ ▓▓▓ ", + " ", + "▓ ▓ ▓" + ] }), ('y', Box { boxColor = withForeColor defAttr magenta, boxLocation = Location '1' 0 (-2), - boxType = Original $ solid 9 + boxType = Original $ makeWalls [ + "▓▓ ▓ ", + " ", + "▓▓ ▓▓▓ ", + "▓▓ ", + " ▓▓▓▓", + "▓▓▓▓ ", + "▓▓ ▓▓▓ ", + " ", + "▓ ▓ ▓" + ] }), ('i', Box { boxColor = withForeColor defAttr black, @@ -155,3 +176,48 @@ loop vty (world :| history) = KEsc -> pure () _ -> loop vty (world :| history) _ -> loop vty (world :| history) + +smallWorld :: World +smallWorld = + World + (Map.fromList + [('a', + Box (Location 'a' 0 0) + (Original (makeWalls [ + "▓▓▓▓▓▓▓▓▓", + "▓ ▓ ▓", + "▓ ▓ ▓", + "▓▓▓▓ ▓", + "▓ ▓", + "▓ ▓", + "▓ ▓", + "▓ ▓", + "▓▓▓▓▓▓▓▓▓" + ])) + (withForeColor defAttr black)), + ('1', + Box + (Location 'a' (-3) (-3)) + (Original (makeWalls (replicate 9 (replicate 9 ' ')))) + (withForeColor defAttr yellow)), + ('2', + Box + (Location 'a' (-3) (-2)) + (Original (makeWalls (replicate 9 (replicate 9 ' ')))) + (withForeColor defAttr magenta)), + ('3', + Box + (Location 'a' (-2) (-3)) + (Original (makeWalls (replicate 9 (replicate 9 ' ')))) + (withForeColor defAttr blue)), + ('4', + Box + (Location 'a' (-2) (-2)) + (Original (makeWalls (replicate 9 (replicate 9 ' ')))) + (withForeColor defAttr green)), + ('b', + Box + (Location '1' 0 0) + (Original (solid 9)) + (withForeColor defAttr red)) + ]) 'b' diff --git a/app/Model.hs b/app/Model.hs index 6baadaf..8662b0a 100644 --- a/app/Model.hs +++ b/app/Model.hs @@ -7,6 +7,7 @@ import Graphics.Vty import Control.Monad import Data.Maybe import Data.Set qualified as Set +import Debug.Trace type Coord = (Int, Int) @@ -66,7 +67,7 @@ solid n = makeWalls (replicate n (replicate n 'x')) move :: World -> (Int,Int) -> World move world dir = - case moveBlock world Map.empty (myLocation world) dir of + case moveBlock world Map.empty (myLocation world) dir 0 of Nothing -> world Just changes -> let f box = box { boxLocation = Map.findWithDefault (boxLocation box) (boxLocation box) changes } in @@ -89,27 +90,29 @@ moveBlock :: Map Location (Int, Location) -> Location -> Movement -> + Rational {- ^ offset -} -> Maybe (Map Location Location) -- moving into a wall, not possible -moveBlock world _ loc _ +moveBlock world _ loc _ _ | isWall world loc = Nothing -- move introduced a loop, trim off the tail and report success -moveBlock _ visited loc _ +moveBlock _ visited loc _ _ | Just (n,_) <- Map.lookup loc visited = Just (fmap snd (Map.filter (\(a,_)->a >= n) visited)) -moveBlock world visited loc dir = +moveBlock world visited loc dir offset = 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 + do (loc', offset') <- nextLoc world dir loc offset + --traceM (show "Next loc " ++ show loc' ++ " offset " ++ show offset') guard (not (isWall world loc')) - moveBlock' world visited loc loc' dir name box + moveBlock' world visited loc loc' dir name box offset' moveBlock' :: World -> @@ -118,38 +121,43 @@ moveBlock' :: Location -> Movement -> Char -> - Box -> + Box -> + Rational {- ^ offset -} -> Maybe (Map Location Location) -moveBlock' world visited loc loc' dir name box = +moveBlock' world visited loc loc' dir name box offset = msum [moveTo, moveInto, moveToEat] where moveTo = - do moveBlock world (addVisited loc loc' visited) loc' dir + do moveBlock world (addVisited loc loc' visited) loc' dir 0 moveInto = do (n,b) <- boxAt world loc' - let locI = enterLoc world n b dir - moveBlock' world visited loc locI dir name box -- beware epsilon! + let (locI, offset') = enterLoc world n b dir offset + moveBlock' world visited loc locI dir name box offset' -- beware epsilon! moveToEat = do let dir' = invert dir - let locE = enterLoc world name box dir' + let (locE, _) = enterLoc world name box dir' 0 (name', box') <- boxAt world loc' - moveBlock' world (addVisited loc loc' visited) loc' locE dir' name' box' + moveBlock' world (addVisited loc loc' visited) loc' locE dir' name' box' 0 -enterLoc :: World -> Char -> Box -> Movement -> Location -enterLoc world name box dir = +enterLoc :: World -> Char -> Box -> Movement -> Rational -> (Location, Rational) +enterLoc world name box dir@(dy,dx) offset = 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 + (-1, 0) -> go yhi (midpoint xlo xhi offset) + ( 1, 0) -> go ylo (midpoint xlo xhi offset) + ( 0,-1) -> go (midpoint ylo yhi offset) xhi + ( 0, 1) -> go (midpoint ylo yhi offset) xlo _ -> error "enterLoc: bad direction" where name' = case boxType box of Link c -> c Original{} -> name ((ylo,xlo),(yhi,xhi)) = bounds (boxWalls world box) + go y x = (Location name' y x, + fromIntegral(boxSize world box) * offset + - fromIntegral ((abs dy *x + abs dx*y))) + boxAt :: World -> Location -> Maybe (Char, Box) boxAt world loc = @@ -158,8 +166,8 @@ boxAt world loc = invert :: Movement -> Movement invert (dy,dx) = (-dy, -dx) -midpoint :: Int -> Int -> Int -midpoint lo hi = (hi+lo)`div`2 +midpoint :: Int -> Int -> Rational -> Int +midpoint lo hi offset = round (offset * fromIntegral (hi-lo+1)) addVisited :: Location {- ^ start -} -> @@ -168,19 +176,21 @@ addVisited :: Map Location (Int, Location) addVisited k v m = Map.insert k (Map.size m, v) m -nextLoc :: World -> Location -> (Int, Int) -> Maybe Location -nextLoc world loc (dy, dx) = go Set.empty loc +nextLoc :: World -> Movement -> Location -> Rational -> Maybe (Location, Rational) +nextLoc world (dy, dx) = go Set.empty where - - go _ (Location b y x) + + go _ (Location b y x) offset | Just box <- Map.lookup b (worldBoxes world) , inRange (bounds (boxWalls world box)) (y+dy, x+dx) - = Just (Location b (y+dy) (x+dx)) + = Just (Location b (y+dy) (x+dx), offset) - go visited (Location b _ _) + go visited (Location b y x) offset | Just box <- Map.lookup b (worldBoxes world) , Set.notMember b visited = go (Set.insert b visited) (boxLocation box) + $ (offset + fromIntegral (abs dy*x+abs dx*y)) + / fromIntegral (boxSize world box) - go _ _ = Nothing + go _ _ _ = Nothing