subpixel into
This commit is contained in:
Eric Mertens
parent
3cd62194b9
commit
b63b11659b
88
app/Main.hs
88
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'
|
||||
|
||||
66
app/Model.hs
66
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
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user