Refactor, try to limit dependencies
This commit is contained in:
@@ -1,35 +1,35 @@
|
||||
module Dodge.Debug.LinkDecoration
|
||||
( addRoomLinkDecorations
|
||||
, addRoomPolyDecorations
|
||||
) where
|
||||
import Dodge.Data
|
||||
import Dodge.RoomLink
|
||||
--import Dodge.Base
|
||||
--import Dodge.LevelGen.Data
|
||||
import Picture
|
||||
import qualified IntMapHelp as IM
|
||||
import Geometry.Data
|
||||
import Geometry.Vector
|
||||
module Dodge.Debug.LinkDecoration (
|
||||
addRoomLinkDecorations,
|
||||
addRoomPolyDecorations,
|
||||
) where
|
||||
|
||||
import Control.Lens
|
||||
import Dodge.Data.GenWorld
|
||||
import Dodge.RoomLink
|
||||
import Geometry.Data
|
||||
import Geometry.Vector
|
||||
import qualified IntMapHelp as IM
|
||||
import Picture
|
||||
|
||||
addRoomPolyDecorations :: [Room] -> World -> World
|
||||
addRoomPolyDecorations rms w = w & cWorld . decorations %~
|
||||
IM.insertWithNewKeys (map roomPolyDecorations rms)
|
||||
addRoomPolyDecorations rms w =
|
||||
w & cWorld . decorations
|
||||
%~ IM.insertWithNewKeys (map roomPolyDecorations rms)
|
||||
|
||||
addRoomLinkDecorations :: [Room] -> World -> World
|
||||
addRoomLinkDecorations rms w = w & cWorld . decorations %~
|
||||
IM.insertWithNewKeys (map roomLinkDecorations rms)
|
||||
addRoomLinkDecorations rms w =
|
||||
w & cWorld . decorations
|
||||
%~ IM.insertWithNewKeys (map roomLinkDecorations rms)
|
||||
|
||||
roomLinkDecorations :: Room -> Picture
|
||||
roomLinkDecorations rm = pictures . map (linkDecoration . lnkPosDir) $ _rmLinks rm
|
||||
|
||||
linkDecoration :: (Point2,Float) -> Picture
|
||||
linkDecoration (p,a) = setLayer DebugLayer . color red $ line [p, p +.+ 20 *.* unitVectorAtAngle (a - pi/2)]
|
||||
linkDecoration :: (Point2, Float) -> Picture
|
||||
linkDecoration (p, a) = setLayer DebugLayer . color red $ line [p, p +.+ 20 *.* unitVectorAtAngle (a - pi / 2)]
|
||||
|
||||
roomPolyDecorations :: Room -> Picture
|
||||
roomPolyDecorations rm = pictures . map polyWireFrame $ _rmPolys rm
|
||||
|
||||
polyWireFrame :: [Point2] -> Picture
|
||||
polyWireFrame (x:xs) = setLayer DebugLayer . setDepth 50 . color green $ line $ (x:xs) ++ [x]
|
||||
polyWireFrame (x : xs) = setLayer DebugLayer . setDepth 50 . color green $ line $ (x : xs) ++ [x]
|
||||
polyWireFrame _ = undefined
|
||||
|
||||
+44
-39
@@ -1,45 +1,48 @@
|
||||
module Dodge.Debug.Picture where
|
||||
import Dodge.Data
|
||||
import Dodge.Base.Window
|
||||
|
||||
import Data.Maybe
|
||||
import Dodge.Base.Wall
|
||||
import Dodge.Base.Window
|
||||
import Dodge.Data.Universe
|
||||
import Geometry
|
||||
import Picture
|
||||
|
||||
import Data.Maybe
|
||||
--import Color
|
||||
|
||||
printPoint :: Point2 -> Picture
|
||||
printPoint p = color white $ uncurryV translate p $ pictures [circle 3 ,scale 0.05 0.05 $ text (show p)]
|
||||
printPoint p = color white $ uncurryV translate p $ pictures [circle 3, scale 0.05 0.05 $ text (show p)]
|
||||
|
||||
printRotPoint :: Float -> Point2 -> Picture
|
||||
printRotPoint r p = color white
|
||||
. uncurryV translate p
|
||||
$ pictures [circle 3 , rotate (negate r) $ scale 0.1 0.1 $ text (show p)]
|
||||
printRotPoint r p =
|
||||
color white
|
||||
. uncurryV translate p
|
||||
$ pictures [circle 3, rotate (negate r) $ scale 0.1 0.1 $ text (show p)]
|
||||
|
||||
outsideScreenPolygon :: Configuration -> World -> [Point2]
|
||||
outsideScreenPolygon cfig w = [tr,tl,bl,br]
|
||||
where
|
||||
scRot = rotateV (_cameraRot (_cWorld w))
|
||||
scZoom p | _cameraZoom (_cWorld w) /= 0 = (1/_cameraZoom (_cWorld w)) *.* p
|
||||
| otherwise = error "Trying to set screen zoom to zero"
|
||||
outsideScreenPolygon cfig w = [tr, tl, bl, br]
|
||||
where
|
||||
scRot = rotateV (_cameraRot (_cWorld w))
|
||||
scZoom p
|
||||
| _cameraZoom (_cWorld w) /= 0 = (1 / _cameraZoom (_cWorld w)) *.* p
|
||||
| otherwise = error "Trying to set screen zoom to zero"
|
||||
scTran p = p +.+ _cameraCenter (_cWorld w)
|
||||
tr = f 3 3
|
||||
tl = f (-3) 3
|
||||
br = f 3 (-3)
|
||||
tr = f 3 3
|
||||
tl = f (-3) 3
|
||||
br = f 3 (-3)
|
||||
bl = f (-3) (-3)
|
||||
f a b = scTran $ scRot $ scZoom $ V2 (a*halfWidth cfig) (b* halfHeight cfig)
|
||||
f a b = scTran $ scRot $ scZoom $ V2 (a * halfWidth cfig) (b * halfHeight cfig)
|
||||
|
||||
-- cannot only test if walls are on screen, but also if they are on the cone
|
||||
-- towards the center of sight
|
||||
lineOnScreenCone :: Configuration -> World -> Point2 -> Point2 -> Bool
|
||||
lineOnScreenCone cfig w p1 p2 = pointInPolygon p1 sp
|
||||
|| pointInPolygon p2 sp
|
||||
|| any (isJust . uncurry (intersectSegSeg p1 p2)) sps
|
||||
where
|
||||
lineOnScreenCone cfig w p1 p2 =
|
||||
pointInPolygon p1 sp
|
||||
|| pointInPolygon p2 sp
|
||||
|| any (isJust . uncurry (intersectSegSeg p1 p2)) sps
|
||||
where
|
||||
sp' = screenPolygon cfig w
|
||||
vp = _cameraViewFrom (_cWorld w)
|
||||
sp | pointInPolygon vp sp' = sp'
|
||||
| otherwise = orderPolygon (_cameraViewFrom (_cWorld w) : sp')
|
||||
sp
|
||||
| pointInPolygon vp sp' = sp'
|
||||
| otherwise = orderPolygon (_cameraViewFrom (_cWorld w) : sp')
|
||||
sps = zip sp (tail sp ++ [head sp])
|
||||
|
||||
pointOnScreen :: Configuration -> World -> Point2 -> Bool
|
||||
@@ -49,26 +52,28 @@ drawWallFace :: Configuration -> World -> Wall -> Picture
|
||||
drawWallFace cfig w wall
|
||||
| isRHS sightFrom x y || not (wlIsOpaque wall) = blank
|
||||
| otherwise = setDepth (-1) . color (withAlpha 0 black) . polygon $ points
|
||||
where
|
||||
(x,y) = _wlLine wall
|
||||
points = extendConeToScreenEdge cfig w sightFrom (x,y)
|
||||
where
|
||||
(x, y) = _wlLine wall
|
||||
points = extendConeToScreenEdge cfig w sightFrom (x, y)
|
||||
sightFrom = _cameraViewFrom (_cWorld w)
|
||||
|
||||
extendConeToScreenEdge :: Configuration -> World -> Point2 -> (Point2,Point2) -> [Point2]
|
||||
extendConeToScreenEdge cfig w c (x,y) = orderPolygon $ wallScreenIntersect ++ [x,y] ++ borderPs ++ cornerPs
|
||||
where
|
||||
borderPs = mapMaybe (intersectLinefromScreen cfig w c) [x,y]
|
||||
extendConeToScreenEdge :: Configuration -> World -> Point2 -> (Point2, Point2) -> [Point2]
|
||||
extendConeToScreenEdge cfig w c (x, y) = orderPolygon $ wallScreenIntersect ++ [x, y] ++ borderPs ++ cornerPs
|
||||
where
|
||||
borderPs = mapMaybe (intersectLinefromScreen cfig w c) [x, y]
|
||||
scpoly = reverse $ screenPolygon cfig w
|
||||
cornerPs = filter (pointIsInCone c (x,y)) scpoly
|
||||
wallScreenIntersect = mapMaybe (uncurry $ intersectSegSeg y ((2*.*y) -.- x))
|
||||
. loopPairs $ scpoly
|
||||
cornerPs = filter (pointIsInCone c (x, y)) scpoly
|
||||
wallScreenIntersect =
|
||||
mapMaybe (uncurry $ intersectSegSeg y ((2 *.* y) -.- x))
|
||||
. loopPairs
|
||||
$ scpoly
|
||||
|
||||
-- the following assumes that the point a is inside the screen
|
||||
-- it still works otherwise, but it might intersect two points:
|
||||
-- it is not obvious which will be returned
|
||||
intersectLinefromScreen :: Configuration -> World -> Point2 -> Point2 -> Maybe Point2
|
||||
intersectLinefromScreen cfig w a b = listToMaybe
|
||||
. mapMaybe (\(x,y) -> intersectSegLineFrom x y b (b +.+ b -.- a))
|
||||
. loopPairs
|
||||
$ screenPolygon cfig w
|
||||
|
||||
intersectLinefromScreen cfig w a b =
|
||||
listToMaybe
|
||||
. mapMaybe (\(x, y) -> intersectSegLineFrom x y b (b +.+ b -.- a))
|
||||
. loopPairs
|
||||
$ screenPolygon cfig w
|
||||
|
||||
+69
-64
@@ -1,47 +1,47 @@
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
module Dodge.Debug.Terminal
|
||||
where
|
||||
import MaybeHelp
|
||||
import Dodge.Inventory.Add
|
||||
import Dodge.Creature
|
||||
import Dodge.Data
|
||||
import Dodge.Menu.PushPop
|
||||
import Dodge.Item
|
||||
import Control.Monad
|
||||
--import Dodge.Base
|
||||
|
||||
import Control.Lens
|
||||
import Text.Read (readMaybe)
|
||||
import Data.List --(isPrefixOf, isInfixOf, intercalate)
|
||||
import Data.Maybe
|
||||
module Dodge.Debug.Terminal where
|
||||
|
||||
import Control.Applicative
|
||||
import LensHelp
|
||||
import Control.Lens
|
||||
import Control.Monad
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
import qualified Data.Text as T
|
||||
import Dodge.Creature
|
||||
import Dodge.Data.Universe
|
||||
import Dodge.Inventory.Add
|
||||
import Dodge.Item
|
||||
import Dodge.Menu.PushPop
|
||||
import qualified IntMapHelp as IM
|
||||
--import qualified Debug.Trace
|
||||
--import Graphics.Rendering.OpenGL.GL.Shaders (validateProgram)
|
||||
--import Dodge.Data (Universe(Universe))
|
||||
import LensHelp
|
||||
import MaybeHelp
|
||||
import Text.Read (readMaybe)
|
||||
|
||||
applyTerminalString :: [String] -> Universe -> Universe
|
||||
applyTerminalString ss = case ss of
|
||||
[] -> id
|
||||
[s] -> applyTerminalCommand s
|
||||
(s:ss') -> applyTerminalCommandArguments s ss'
|
||||
(s : ss') -> applyTerminalCommandArguments s ss'
|
||||
|
||||
applyTerminalCommand :: String -> Universe -> Universe
|
||||
applyTerminalCommand s = case s of
|
||||
"NOCLIP" -> uvConfig . debug_booleans . at Noclip %~ toggleJust
|
||||
"LOADME" -> (uvWorld . cWorld . creatures . ix 0 . crInv .~ stackedInventory)
|
||||
. (uvWorld . cWorld . creatures . ix 0 . crInvCapacity .~ 50)
|
||||
"LM" -> applyTerminalCommand "LOADME"
|
||||
"LT" -> applyTerminalCommand "LOADTEST"
|
||||
['L',x] -> (uvWorld . cWorld . creatures . ix 0 . crInv .~ IM.fromList (zip [0..] $ inventoryX x))
|
||||
. (uvWorld . cWorld . creatures . ix 0 . crInvCapacity .~ 50)
|
||||
"GODON" -> uvWorld . cWorld . creatures . ix 0 . crMaterial .~ Crystal
|
||||
"GODOFF" -> uvWorld . cWorld . creatures . ix 0 . crMaterial .~ Flesh
|
||||
"LOADTEST" -> (uvWorld . cWorld . creatures . ix 0 . crInv .~ testInventory)
|
||||
. (uvWorld . cWorld . creatures . ix 0 . crInvCapacity .~ 50)
|
||||
"LOADME" ->
|
||||
(uvWorld . cWorld . creatures . ix 0 . crInv .~ stackedInventory)
|
||||
. (uvWorld . cWorld . creatures . ix 0 . crInvCapacity .~ 50)
|
||||
"LM" -> applyTerminalCommand "LOADME"
|
||||
"LT" -> applyTerminalCommand "LOADTEST"
|
||||
['L', x] ->
|
||||
(uvWorld . cWorld . creatures . ix 0 . crInv .~ IM.fromList (zip [0 ..] $ inventoryX x))
|
||||
. (uvWorld . cWorld . creatures . ix 0 . crInvCapacity .~ 50)
|
||||
"GODON" -> uvWorld . cWorld . creatures . ix 0 . crMaterial .~ Crystal
|
||||
"GODOFF" -> uvWorld . cWorld . creatures . ix 0 . crMaterial .~ Flesh
|
||||
"LOADTEST" ->
|
||||
(uvWorld . cWorld . creatures . ix 0 . crInv .~ testInventory)
|
||||
. (uvWorld . cWorld . creatures . ix 0 . crInvCapacity .~ 50)
|
||||
_ -> id
|
||||
|
||||
--applyTerminalString' ('s': 'e': 't': '_': 'h': 'p': ' ': hp)
|
||||
-- | isNothing (readMaybe hp :: Maybe Int) = id
|
||||
-- | otherwise = uvWorld . creatures . ix 0 . crHP .~ read hp
|
||||
@@ -59,20 +59,20 @@ applyTerminalCommand s = case s of
|
||||
applyTerminalCommandArguments :: String -> [String] -> Universe -> Universe
|
||||
applyTerminalCommandArguments command args u = case command of
|
||||
"ITEM" -> fromMaybe u $ do
|
||||
(ibt,n) <- parseItem args
|
||||
(ibt, n) <- parseItem args
|
||||
return $ u & uvWorld %~ flip (foldr ($)) (replicate n (snd . createPutItem (itemFromBase ibt)))
|
||||
_ -> u
|
||||
|
||||
parseItem :: [String] -> Maybe (ItemBaseType,Int)
|
||||
parseItem (x:xs)
|
||||
= (readMaybe (x++" {_xNum=" ++ show (parseNum xs)++"}") <&> (,1))
|
||||
<|> (readMaybe x <&> (,parseNum xs) )
|
||||
<|> (readMaybe ("CRAFT "++x) <&> (,parseNum xs))
|
||||
<|> (readMaybe ("HELD {_ibtHeld="++x++"}") <&> (,parseNum xs))
|
||||
<|> (readMaybe ("EQUIP {_ibtEquip="++x++"}") <&> (,parseNum xs))
|
||||
<|> (readMaybe ("LEFT {_ibtLEFT="++x++"}") <&> (,parseNum xs))
|
||||
<|> (readMaybe ("HELD ("++x++" {_xNum=" ++ show (parseNum xs)++"}") <&> (,1))
|
||||
<|> parseItem (xs & ix 0 .++~ (x ++ " "))
|
||||
parseItem :: [String] -> Maybe (ItemBaseType, Int)
|
||||
parseItem (x : xs) =
|
||||
(readMaybe (x ++ " {_xNum=" ++ show (parseNum xs) ++ "}") <&> (,1))
|
||||
<|> (readMaybe x <&> (,parseNum xs))
|
||||
<|> (readMaybe ("CRAFT " ++ x) <&> (,parseNum xs))
|
||||
<|> (readMaybe ("HELD {_ibtHeld=" ++ x ++ "}") <&> (,parseNum xs))
|
||||
<|> (readMaybe ("EQUIP {_ibtEquip=" ++ x ++ "}") <&> (,parseNum xs))
|
||||
<|> (readMaybe ("LEFT {_ibtLEFT=" ++ x ++ "}") <&> (,parseNum xs))
|
||||
<|> (readMaybe ("HELD (" ++ x ++ " {_xNum=" ++ show (parseNum xs) ++ "}") <&> (,1))
|
||||
<|> parseItem (xs & ix 0 .++~ (x ++ " "))
|
||||
parseItem [] = Nothing
|
||||
|
||||
parseNum :: [String] -> Int
|
||||
@@ -84,20 +84,21 @@ showTerminalError cmd s = menuLayers .:~ InputScreen (T.pack cmd) s
|
||||
applySetTerminalString :: String -> Universe -> Universe
|
||||
applySetTerminalString [] = id
|
||||
applySetTerminalString var = case key' of
|
||||
"" -> showTerminalError ("set "++var) ("Unable to read as argument as float: " ++ val)
|
||||
"" -> showTerminalError ("set " ++ var) ("Unable to read as argument as float: " ++ val)
|
||||
"hp" -> uvWorld . cWorld . creatures . ix 0 . crHP .~ round (fromJust val')
|
||||
"invcap" -> uvWorld . cWorld . creatures . ix 0 . crInvCapacity .~ round (fromJust val')
|
||||
"mass" -> uvWorld . cWorld . creatures . ix 0 . crMass .~ fromJust val'
|
||||
"mvspeed" -> uvWorld . cWorld . creatures . ix 0 . crMvType .mvSpeed .~ fromJust val'
|
||||
_ -> showTerminalError ("set "++var) ("Invalid set command: " ++ key) -- never reached?
|
||||
where
|
||||
(key, val) = getSplitString var
|
||||
val' = readMaybe val :: Maybe Float
|
||||
key' = if isNothing val' then "" else key
|
||||
"mvspeed" -> uvWorld . cWorld . creatures . ix 0 . crMvType . mvSpeed .~ fromJust val'
|
||||
_ -> showTerminalError ("set " ++ var) ("Invalid set command: " ++ key) -- never reached?
|
||||
where
|
||||
(key, val) = getSplitString var
|
||||
val' = readMaybe val :: Maybe Float
|
||||
key' = if isNothing val' then "" else key
|
||||
|
||||
autoCompleteTerminal :: String -> String -> Universe -> IO (Maybe Universe)
|
||||
autoCompleteTerminal s _ = return .
|
||||
(popScreen' >=> pushScreen' (InputScreen (T.pack input_str) valid_commands))
|
||||
autoCompleteTerminal s _ =
|
||||
return
|
||||
. (popScreen' >=> pushScreen' (InputScreen (T.pack input_str) valid_commands))
|
||||
where
|
||||
(key, val) = getSplitString $ tail s
|
||||
command_options = case val of
|
||||
@@ -105,24 +106,28 @@ autoCompleteTerminal s _ = return .
|
||||
_ -> filter (isInfixOf val) (validTerminalCommands key)
|
||||
-- basic autocomplete if single option available (or as far as possible)
|
||||
input_str = case (key, val) of
|
||||
(_, "") -> if length command_options == 1
|
||||
then ">" ++ head command_options ++ " "
|
||||
else ">" ++ longestCommonPrefix command_options
|
||||
_ -> if length command_options == 1
|
||||
then ">" ++ key ++ " " ++ head command_options ++ " "
|
||||
else if null command_options
|
||||
then s
|
||||
else ">" ++ key ++ " " ++ longestCommonPrefix command_options
|
||||
command_options' = if not (null command_options) && head command_options == key
|
||||
then validTerminalCommands key
|
||||
else command_options
|
||||
(_, "") ->
|
||||
if length command_options == 1
|
||||
then ">" ++ head command_options ++ " "
|
||||
else ">" ++ longestCommonPrefix command_options
|
||||
_ ->
|
||||
if length command_options == 1
|
||||
then ">" ++ key ++ " " ++ head command_options ++ " "
|
||||
else
|
||||
if null command_options
|
||||
then s
|
||||
else ">" ++ key ++ " " ++ longestCommonPrefix command_options
|
||||
command_options' =
|
||||
if not (null command_options) && head command_options == key
|
||||
then validTerminalCommands key
|
||||
else command_options
|
||||
|
||||
--val' = Debug.Trace.trace key tail val
|
||||
valid_commands = "Options: " ++ intercalate ", " command_options'
|
||||
|
||||
getSplitString :: [Char] -> ([Char], [Char])
|
||||
getSplitString str = case break (==' ') str of
|
||||
(a, _:b) -> (a, b)
|
||||
getSplitString str = case break (== ' ') str of
|
||||
(a, _ : b) -> (a, b)
|
||||
(a, _) -> (a, "")
|
||||
|
||||
isValidCommand :: String -> String -> Bool
|
||||
@@ -141,6 +146,6 @@ longestCommonPrefix [] = []
|
||||
longestCommonPrefix lists = foldr1 commonPrefix lists
|
||||
|
||||
commonPrefix :: Eq a => [a] -> [a] -> [a]
|
||||
commonPrefix (x:xs) (y:ys)
|
||||
| x == y = x : commonPrefix xs ys
|
||||
commonPrefix (x : xs) (y : ys)
|
||||
| x == y = x : commonPrefix xs ys
|
||||
commonPrefix _ _ = []
|
||||
|
||||
Reference in New Issue
Block a user