glguy/parabox
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

subpixel into

Browse Source
This commit is contained in:
Eric Mertens 2022-12-02 18:49:26 -08:00
parent 3cd62194b9
commit b63b11659b
2 changed files with 115 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

88
app/Main.hs
View File

@ -34,8 +34,8 @@ world0 = World {
boxType = Original $ makeWalls [ boxType = Original $ makeWalls [
"▓ ▓▓ ▓▓ ▓", "▓ ▓▓ ▓▓ ▓",
" ", " ",
"▓ ▓", " ▓",
"▓ ▓", " ▓",
" ", " ",
"▓ ▓", "▓ ▓",
"▓ ▓", "▓ ▓",
@ -53,11 +53,11 @@ world0 = World {
boxLocation = Location '2' 1 1, boxLocation = Location '2' 1 1,
boxType = Original $ makeWalls [ boxType = Original $ makeWalls [
"▓▓▓▓▓▓▓▓▓", "▓▓▓▓▓▓▓▓▓",
"▓▓▓▓▓▓▓▓▓", " ",
"▓▓▓▓▓▓▓▓▓", "▓▓▓▓▓▓▓▓ ",
"▓▓ ▓▓▓▓", "▓▓ ▓▓▓ ",
"▓▓ ▓▓▓▓", "▓▓ ▓▓▓ ",
"▓▓▓▓ ▓▓▓▓", "▓▓▓▓ ▓▓▓ ",
"▓▓ ▓▓▓▓", "▓▓ ▓▓▓▓",
"▓▓ ▓▓▓▓", "▓▓ ▓▓▓▓",
"▓▓▓▓ ▓▓▓▓" "▓▓▓▓ ▓▓▓▓"
@ -85,9 +85,9 @@ world0 = World {
"▓▓▓▓▓▓▓▓▓", "▓▓▓▓▓▓▓▓▓",
"▓ ▓", "▓ ▓",
"▓ ▓", "▓ ▓",
"▓ ▓ ▓ ▓",
"▓ ▓",
"▓ ▓", "▓ ▓",
" ",
"▓ ▓▓",
"▓ ▓", "▓ ▓",
"▓ ▓", "▓ ▓",
"▓▓▓▓▓▓▓▓▓" "▓▓▓▓▓▓▓▓▓"
@ -96,12 +96,33 @@ world0 = World {
('x', Box { ('x', Box {
boxColor = withForeColor defAttr yellow, boxColor = withForeColor defAttr yellow,
boxLocation = Location '1' 0 (-1), boxLocation = Location '1' 0 (-1),
boxType = Original $ solid 9 boxType = Original $
makeWalls [
"▓▓ ▓ ",
" ",
" ▓ ▓▓▓ ",
" ▓ ",
"▓ ▓▓▓▓",
" ▓▓▓ ",
" ▓ ▓▓▓ ",
" ",
"▓ ▓ ▓"
]
}), }),
('y', Box { ('y', Box {
boxColor = withForeColor defAttr magenta, boxColor = withForeColor defAttr magenta,
boxLocation = Location '1' 0 (-2), boxLocation = Location '1' 0 (-2),
boxType = Original $ solid 9 boxType = Original $ makeWalls [
"▓▓ ▓ ",
" ",
"▓▓ ▓▓▓ ",
"▓▓ ",
" ▓▓▓▓",
"▓▓▓▓ ",
"▓▓ ▓▓▓ ",
" ",
"▓ ▓ ▓"
]
}), }),
('i', Box { ('i', Box {
boxColor = withForeColor defAttr black, boxColor = withForeColor defAttr black,
@ -155,3 +176,48 @@ loop vty (world :| history) =
KEsc -> pure () KEsc -> pure ()
_ -> loop vty (world :| history) _ -> loop vty (world :| history)
_ -> 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'

66
app/Model.hs
View File

@ -7,6 +7,7 @@ import Graphics.Vty
import Control.Monad import Control.Monad
import Data.Maybe import Data.Maybe
import Data.Set qualified as Set import Data.Set qualified as Set
import Debug.Trace
type Coord = (Int, Int) type Coord = (Int, Int)
@ -66,7 +67,7 @@ solid n = makeWalls (replicate n (replicate n 'x'))
move :: World -> (Int,Int) -> World move :: World -> (Int,Int) -> World
move world dir = move world dir =
case moveBlock world Map.empty (myLocation world) dir of case moveBlock world Map.empty (myLocation world) dir 0 of
Nothing -> world Nothing -> world
Just changes -> Just changes ->
let f box = box { boxLocation = Map.findWithDefault (boxLocation box) (boxLocation box) changes } in let f box = box { boxLocation = Map.findWithDefault (boxLocation box) (boxLocation box) changes } in
@ -89,27 +90,29 @@ moveBlock ::
Map Location (Int, Location) -> Map Location (Int, Location) ->
Location -> Location ->
Movement -> Movement ->
Rational {- ^ offset -} ->
Maybe (Map Location Location) Maybe (Map Location Location)
-- moving into a wall, not possible -- moving into a wall, not possible
moveBlock world _ loc _ moveBlock world _ loc _ _
| isWall world loc = Nothing | isWall world loc = Nothing
-- move introduced a loop, trim off the tail and report success -- move introduced a loop, trim off the tail and report success
moveBlock _ visited loc _ moveBlock _ visited loc _ _
| Just (n,_) <- Map.lookup loc visited | Just (n,_) <- Map.lookup loc visited
= Just (fmap snd (Map.filter (\(a,_)->a >= n) 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 case [(n,box) | (n,box) <- Map.assocs (worldBoxes world), boxLocation box == loc] of
-- moving an empty space, so we're done -- moving an empty space, so we're done
[] -> Just (fmap snd visited) [] -> Just (fmap snd visited)
-- moving a box -- moving a box
(name,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')) guard (not (isWall world loc'))
moveBlock' world visited loc loc' dir name box moveBlock' world visited loc loc' dir name box offset'
moveBlock' :: moveBlock' ::
World -> World ->
@ -118,38 +121,43 @@ moveBlock' ::
Location -> Location ->
Movement -> Movement ->
Char -> Char ->
Box -> Box ->
Rational {- ^ offset -} ->
Maybe (Map Location Location) 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] msum [moveTo, moveInto, moveToEat]
where where
moveTo = moveTo =
do moveBlock world (addVisited loc loc' visited) loc' dir do moveBlock world (addVisited loc loc' visited) loc' dir 0
moveInto = moveInto =
do (n,b) <- boxAt world loc' do (n,b) <- boxAt world loc'
let locI = enterLoc world n b dir let (locI, offset') = enterLoc world n b dir offset
moveBlock' world visited loc locI dir name box -- beware epsilon! moveBlock' world visited loc locI dir name box offset' -- beware epsilon!
moveToEat = moveToEat =
do let dir' = invert dir 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' (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 -> Char -> Box -> Movement -> Rational -> (Location, Rational)
enterLoc world name box dir = enterLoc world name box dir@(dy,dx) offset =
case dir of case dir of
(-1, 0) -> Location name' yhi (midpoint xlo xhi) (-1, 0) -> go yhi (midpoint xlo xhi offset)
( 1, 0) -> Location name' ylo (midpoint xlo xhi) ( 1, 0) -> go ylo (midpoint xlo xhi offset)
( 0,-1) -> Location name' (midpoint ylo yhi) xhi ( 0,-1) -> go (midpoint ylo yhi offset) xhi
( 0, 1) -> Location name' (midpoint ylo yhi) xlo ( 0, 1) -> go (midpoint ylo yhi offset) xlo
_ -> error "enterLoc: bad direction" _ -> error "enterLoc: bad direction"
where where
name' = case boxType box of name' = case boxType box of
Link c -> c Link c -> c
Original{} -> name Original{} -> name
((ylo,xlo),(yhi,xhi)) = bounds (boxWalls world box) ((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 -> Location -> Maybe (Char, Box)
boxAt world loc = boxAt world loc =
@ -158,8 +166,8 @@ boxAt world loc =
invert :: Movement -> Movement invert :: Movement -> Movement
invert (dy,dx) = (-dy, -dx) invert (dy,dx) = (-dy, -dx)
midpoint :: Int -> Int -> Int midpoint :: Int -> Int -> Rational -> Int
midpoint lo hi = (hi+lo)`div`2 midpoint lo hi offset = round (offset * fromIntegral (hi-lo+1))
addVisited :: addVisited ::
Location {- ^ start -} -> Location {- ^ start -} ->
@ -168,19 +176,21 @@ addVisited ::
Map Location (Int, Location) Map Location (Int, Location)
addVisited k v m = Map.insert k (Map.size m, v) m addVisited k v m = Map.insert k (Map.size m, v) m
nextLoc :: World -> Location -> (Int, Int) -> Maybe Location nextLoc :: World -> Movement -> Location -> Rational -> Maybe (Location, Rational)
nextLoc world loc (dy, dx) = go Set.empty loc nextLoc world (dy, dx) = go Set.empty
where where
go _ (Location b y x) go _ (Location b y x) offset
| Just box <- Map.lookup b (worldBoxes world) | Just box <- Map.lookup b (worldBoxes world)
, inRange (bounds (boxWalls world box)) (y+dy, x+dx) , 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) | Just box <- Map.lookup b (worldBoxes world)
, Set.notMember b visited , Set.notMember b visited
= go (Set.insert b visited) (boxLocation box) = go (Set.insert b visited) (boxLocation box)
$ (offset + fromIntegral (abs dy*x+abs dx*y))
/ fromIntegral (boxSize world box)
go _ _ = Nothing go _ _ _ = Nothing