From 84cb83080400dc7a563be9832b49a0406c08636c Mon Sep 17 00:00:00 2001 From: justin Date: Wed, 29 Jun 2022 19:20:27 +0100 Subject: [PATCH] Add debugging for pathfinding --- src/Dodge/Config/Data.hs | 3 +- src/Dodge/Data.hs | 5 +- src/Dodge/Default/World.hs | 7 +- src/Dodge/Path.hs | 26 ++- src/Dodge/Render/ShapePicture.hs | 107 +++++---- src/Dodge/Update.hs | 23 +- src/Dodge/Update/UsingInput.hs | 2 +- src/Dodge/WorldEvent/ThingsHit.hs | 1 - src/Dodge/Zone.hs | 8 +- src/Dodge/Zone/Size.hs | 3 + src/FoldableHelp.hs | 1 - src/Picture.hs | 368 +---------------------------- src/Picture/Base.hs | 373 ++++++++++++++++++++++++++++++ src/Picture/Composite.hs | 16 ++ 14 files changed, 511 insertions(+), 432 deletions(-) create mode 100644 src/Picture/Base.hs create mode 100644 src/Picture/Composite.hs diff --git a/src/Dodge/Config/Data.hs b/src/Dodge/Config/Data.hs index 09cef2ffa..9bf40d033 100644 --- a/src/Dodge/Config/Data.hs +++ b/src/Dodge/Config/Data.hs @@ -21,7 +21,7 @@ data Configuration = Configuration , _windowPosY :: Int , _gameplay_rotate_to_wall :: Bool , _debug_view_clip_bounds :: RoomClipping - , _debug_booleans :: S.Set DebugBool -- consider using Data.BitSet + , _debug_booleans :: S.Set DebugBool -- consider using Data.BitSet } deriving (Generic, Show) data DebugBool @@ -44,6 +44,7 @@ data DebugBool | Show_far_wall_detect | Show_select | Inspect_wall + | Show_nodes_near_select deriving (Generic, Eq,Ord,Bounded, Enum, Show) data ResFactor = FullRes | HalfRes | QuarterRes deriving (Generic, Show, Eq, Ord, Enum, Bounded) diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index b290260d7..cb82f08f7 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -172,7 +172,10 @@ data World = World , _genRooms :: IM.IntMap Room , _deathDelay :: Maybe Int , _testFloat :: Float - , _wSelect :: (Point2,Point2) + , _lLine :: (Point2,Point2) + , _rLine :: (Point2,Point2) + , _lSelect :: Point2 + , _rSelect :: Point2 } data WorldHammer = SubInvHam diff --git a/src/Dodge/Default/World.hs b/src/Dodge/Default/World.hs index 41420c833..1cf614096 100644 --- a/src/Dodge/Default/World.hs +++ b/src/Dodge/Default/World.hs @@ -74,7 +74,7 @@ defaultWorld = World , _clickMousePos = V2 0 0 , _pathGraph = Data.Graph.Inductive.Graph.empty , _pathGraphP = mempty - , _phZoning = Zoning mempty wlZoneSize (zonePos snd) + , _phZoning = Zoning mempty phZoneSize (zonePos snd) , _hud = HUD { _hudElement = DisplayInventory NoSubInventory , _carteCenter = V2 0 0 @@ -111,7 +111,10 @@ defaultWorld = World , _testFloat = 0 , _boundBox = square 100 , _boundDist = (100,-100,100,-100) - , _wSelect = (0,0) + , _lLine = (0,0) + , _rLine = (0,0) + , _lSelect = 0 + , _rSelect = 0 } defaultWorldHammers :: M.Map WorldHammer HammerPosition defaultWorldHammers = M.fromSet (const HammerUp) $ S.fromList [minBound.. maxBound] diff --git a/src/Dodge/Path.hs b/src/Dodge/Path.hs index ffa337bf5..dd1517f17 100644 --- a/src/Dodge/Path.hs +++ b/src/Dodge/Path.hs @@ -4,6 +4,9 @@ module Dodge.Path , makePathBetweenPs , removePathsCrossing , pairsToGraph + , walkableNodeNear + , nodesNearL + , getNodePos ) where import Dodge.Data import Dodge.Base.Collide @@ -18,21 +21,28 @@ import Data.List import Data.Graph.Inductive hiding ((&)) import qualified Data.Set as Set import qualified Streaming.Prelude as S +import StreamingHelp --import Data.Graph.Inductive.PatriciaTree --import Data.Graph.Inductive.Graph hiding ((&)) +getNodePos :: Int -> World -> Maybe Point2 +getNodePos i w = _pathGraph w `lab` i + makePathBetween :: Point2 -> Point2 -> World -> Maybe [Int] makePathBetween a b w = do -- join $ sp <$> a' <*> b' <*> return (_pathGraph w) - na <- walkableNodeNear a - nb <- walkableNodeNear b + (na,_) <- walkableNodeNear a w + (nb,_) <- walkableNodeNear b w sp na nb (_pathGraph w) - where - --nodesNear p = concat $ lookLookups (zoneNearPointIP p) (_pathPoints w) - nodesNear p = runIdentity . S.toList_ $ nearPoint _phZoning p w - walkableNodeNear p = fmap fst . find (flip (isWalkable p) w . snd) $ nodesNear p ---walkableNodeNear :: Point2 -> World -> Maybe Point2 ---walkableNodeNear p w = insideCirc +walkableNodeNear :: Point2 -> World -> Maybe (Int,Point2) +walkableNodeNear p w = minStreamOn (dist p . snd) + . S.filter (flip (isWalkable p) w . snd) $ nodesNear p w + +nodesNear :: Point2 -> World -> StreamOf (Int,Point2) +nodesNear = aroundPoint _phZoning + +nodesNearL :: Point2 -> World -> [(Int,Point2)] +nodesNearL p = runIdentity . S.toList_ . nodesNear p makePathBetweenPs :: Point2 -> Point2 -> World -> Maybe [Point2] makePathBetweenPs a b w = mapMaybe (lab $ _pathGraph w) <$> makePathBetween a b w diff --git a/src/Dodge/Render/ShapePicture.hs b/src/Dodge/Render/ShapePicture.hs index fe3045588..62bdc0c30 100644 --- a/src/Dodge/Render/ShapePicture.hs +++ b/src/Dodge/Render/ShapePicture.hs @@ -16,6 +16,8 @@ import Dodge.Graph import Dodge.GameRoom import Dodge.Update.Camera import Dodge.Item.Draw +import Dodge.Render.List +import Dodge.Path --import Dodge.Zone import Geometry import Geometry.Zone @@ -76,34 +78,61 @@ extraPics cfig w = pictures (_decorations w) -- <> runIdentity (S.foldMap_ clDraw (_clouds w)) <> concatMapPic clDraw (_clouds w ) <> concatMapPic ppDraw (_pressPlates w ) - <> soundPics cfig w <> viewClipBounds cfig w - <> drawMousePosition cfig w - <> drawWallIDs cfig w - <> drawPathing cfig w - <> drawCrInfo cfig w - <> cfigdraw View_boundaries (const viewBoundaries) - <> cfigdraw Show_bound_box (const drawBoundingBox) - <> cfigdraw Show_wall_search_rays (const drawWallSearchRays) - <> cfigdraw Show_dda_test (const drawDDATest) - <> cfigdraw Show_far_wall_detect (const drawFarWallDetect) - <> cfigdraw Show_select (const drawWorldSelect) - <> cfigdraw Inspect_wall (const drawInspectWalls) - <> cfigdraw Cr_awareness (const drawCreatureDisplayTexts) + <> debugDraw cfig w + +debugDraw :: Configuration -> World -> Picture +debugDraw cfig w = pic + <> setLayer FixedCoordLayer (listPicturesAt (0.5*halfWidth cfig) 0 cfig $ map text ts) where - cfigdraw boption draw - | debugOn boption cfig = draw cfig w - | otherwise = mempty + (ts, pic) = foldMap (f . debugDraw' cfig w) (_debug_booleans cfig) + f (Left s) = ([s],mempty) + f (Right pic') = (mempty,pic') + +debugDraw' :: Configuration -> World -> DebugBool -> Either String Picture +debugDraw' cfig w bl = case bl of + Noclip -> Left "Noclip" + Remove_LOS -> Left "No line of sight" + Cull_more_lights -> Left "Cull more lights" + Close_shape_culling -> Left "Close shape culling" + Bound_box_screen -> Left "bound box screen, this should be moved" + Show_ms_frame -> Right mempty + View_boundaries -> Right $ viewBoundaries w + Show_bound_box -> Right $ drawBoundingBox w + Show_wall_search_rays -> Right $ drawWallSearchRays w + Show_dda_test -> Right $ drawDDATest w + Show_far_wall_detect -> Right $ drawFarWallDetect w + Show_select -> Right $ drawWorldSelect w + Inspect_wall -> Right $ drawInspectWalls w + Cr_awareness -> Right $ drawCreatureDisplayTexts w + Show_sound -> Right $ pictures $ M.map (soundPic cfig w) $ _playingSounds w + Cr_status -> Right $ drawCrInfo cfig w + Mouse_position -> Right $ drawMousePosition cfig w + Walls_info -> Right $ drawWlIDs cfig w + Pathing -> Right $ drawPathing w + Show_nodes_near_select -> Right $ drawNodesNearSelect w drawCreatureDisplayTexts :: World -> Picture drawCreatureDisplayTexts w = foldMap (creatureDisplayText w) (_creatures w) +drawNodesNearSelect :: World -> Picture +drawNodesNearSelect w = setLayer DebugLayer $ + runIdentity (S.foldMap_ (drawZone phZoneSize) (zoneAroundPoint phZoneSize sp)) + <> color red (foldMap (drawCross . snd) $ nodesNearL sp w) + <> color green (drawCross sp) + <> color cyan (foldMap (drawCross . snd) $ walkableNodeNear sp w) + <> color yellow (foldMap (arrowPath . mapMaybe (`getNodePos` w)) (makePathBetween sp ep w)) + where + sp = _lSelect w + ep = _rSelect w + + drawInspectWalls :: World -> Picture drawInspectWalls w = foldMap (drawInspectWall w) $ filter (isJust . uncurry (intersectSegSeg a b) . _wlLine) $ IM.elems $ _walls w where - (a,b) = _wSelect w + (a,b) = _lLine w drawInspectWall :: World -> Wall -> Picture drawInspectWall _ wl = setLayer DebugLayer $ @@ -117,10 +146,12 @@ drawInspectWall _ wl = setLayer DebugLayer $ -- (a,b) = _wSelect w drawWorldSelect :: World -> Picture -drawWorldSelect w = setLayer DebugLayer . color cyan - $ line [a,b] +drawWorldSelect w = setLayer DebugLayer + $ color cyan (line [a,b]) + <> color magenta (line [c,d]) where - (a,b) = _wSelect w + (a,b) = _lLine w + (c,d) = _rLine w drawFarWallDetect :: World -> Picture drawFarWallDetect w = setLayer DebugLayer @@ -196,11 +227,6 @@ mcSPic :: Machine -> SPic mcSPic bt = uncurryV translateSPf (_mcPos bt) $ rotateSP (_mcDir bt) (_mcDraw bt bt) -soundPics :: Configuration -> World -> Picture -soundPics cfig w - | debugOn Show_sound cfig = pictures $ M.map (soundPic cfig w) $ _playingSounds w - | otherwise = [] - soundPic :: Configuration -> World -> Sound -> Picture soundPic cfig w s = fixedSizePicClampArrow 50 50 thePic p cfig w where @@ -215,23 +241,17 @@ soundPic cfig w s = fixedSizePicClampArrow 50 50 thePic p cfig w f x = 1 - 0.5 * (1 - x) drawMousePosition :: Configuration -> World -> Picture -drawMousePosition cfig w - | not $ debugOn Mouse_position cfig = mempty - | otherwise - = setLayer FixedCoordLayer . winScale cfig - . uncurryV translate p - . scale 0.1 0.1 - . text - $ shortPoint2 mwp +drawMousePosition cfig w = setLayer FixedCoordLayer . winScale cfig + . uncurryV translate p + . scale 0.1 0.1 + . text + $ shortPoint2 mwp where p = worldPosToScreen w mwp mwp = mouseWorldPos w -drawWallIDs :: Configuration -> World -> Picture -drawWallIDs cfig w - | debugOn Walls_info cfig = setLayer FixedCoordLayer - $ foldMap f (_walls w) - | otherwise = mempty +drawWlIDs :: Configuration -> World -> Picture +drawWlIDs cfig w = setLayer FixedCoordLayer $ foldMap f (_walls w) where f wl | dist (_crPos $ you w) (fst (_wlLine wl)) > 200 = mempty -- this should be improved with a better "on screen test" @@ -243,13 +263,10 @@ drawWallIDs cfig w where p = worldPosToScreen w $ 0.5 *.* uncurry (+.+) (_wlLine wl) -drawPathing :: Configuration -> World -> Picture -drawPathing cfig w - | debugOn Pathing cfig - = setLayer DebugLayer $ +drawPathing :: World -> Picture +drawPathing w = setLayer DebugLayer $ (color green . pictures . map (thickLine 5 . tflat2) $ graphToEdges gr) <> concatMap dispInc (graphToIncidence gr) - | otherwise = [] where dispInc (p,n) = setDepth 2 . uncurryV translate p . scale 0.1 0.1 $ text $ show n gr = _pathGraph w @@ -274,11 +291,9 @@ crDisplayInfo cfig w cr crOnScreen = pointOnScreen cfig w $ _crPos cr drawCrInfo :: Configuration -> World -> Picture -drawCrInfo cfig w - | debugOn Cr_status cfig = setLayer FixedCoordLayer +drawCrInfo cfig w = setLayer FixedCoordLayer $ renderInfoListsAt (2*hw - 400) 0 cfig w $ mapMaybe (crDisplayInfo cfig w) $ IM.elems $ _creatures w - | otherwise = mempty where hw = halfWidth cfig diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index af3ccbf32..276676dad 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -98,15 +98,26 @@ functionalUpdate cfig w = checkEndGame $ updateCloseObjects w zoneClouds :: World -> World -zoneClouds w = w & clZoning %~ \zn -> - foldl' (flip $ updateZoning (:)) (zn & znObjects .~ mempty) (_clouds w) +zoneClouds w = w + & clZoning . znObjects .~ mempty + & clZoning %~ \zn -> + foldl' (flip $ updateZoning (:)) zn (_clouds w) --runIdentity (S.fold_ (flip $ updateZoning (:)) (zn & znObjects .~ mempty) id (_clouds w)) updateWorldSelect :: World -> World -updateWorldSelect w = case w ^? mouseButtons . ix ButtonLeft of - Nothing -> w - Just False -> w & wSelect . _1 .~ mouseWorldPos w - Just True -> w & wSelect . _2 .~ mouseWorldPos w +updateWorldSelect w = f . g $ case (w ^? mouseButtons . ix ButtonLeft, w ^? mouseButtons . ix ButtonRight) of + (Nothing ,Nothing) -> w + (Just False,Nothing) -> w & lLine . _1 .~ mwp + (Just True ,Nothing) -> w & lLine . _2 .~ mwp + (Nothing ,_) -> w + (Just False,_) -> w & rLine . _1 .~ mwp + (Just True ,_) -> w & rLine . _2 .~ mwp + where + mwp = mouseWorldPos w + f | ButtonLeft `M.member` _mouseButtons w = lSelect .~ mwp + | otherwise = id + g | ButtonRight `M.member` _mouseButtons w = rSelect .~ mwp + | otherwise = id mcChooseUpdate :: Machine -> Machine -> World -> World mcChooseUpdate mc mc' diff --git a/src/Dodge/Update/UsingInput.hs b/src/Dodge/Update/UsingInput.hs index 89d4b1866..fe3639f4d 100644 --- a/src/Dodge/Update/UsingInput.hs +++ b/src/Dodge/Update/UsingInput.hs @@ -33,7 +33,7 @@ updatePressedButtons subinv pkeys w = case subinv of | otherwise -> updatePressedButtons' pkeys w CombineInventory mi | pkeys ^? ix ButtonLeft == Just False - -> (maybeexitcombine $ maybe id doCombine mi w) & hammers . ix SubInvHam .~ HammerDown + -> maybeexitcombine (maybe id doCombine mi w) & hammers . ix SubInvHam .~ HammerDown DisplayTerminal tmid | pkeys ^? ix ButtonLeft == Just False && inTermFocus w -> doTerminalEffectLB (w ^?! terminals . ix tmid) w diff --git a/src/Dodge/WorldEvent/ThingsHit.hs b/src/Dodge/WorldEvent/ThingsHit.hs index 18214e99e..80a2fae19 100644 --- a/src/Dodge/WorldEvent/ThingsHit.hs +++ b/src/Dodge/WorldEvent/ThingsHit.hs @@ -4,7 +4,6 @@ Find which objects lie upon a line. -} module Dodge.WorldEvent.ThingsHit ( thingsHit --- , wallsHit , thingHit , thingsHitExceptCr ) diff --git a/src/Dodge/Zone.hs b/src/Dodge/Zone.hs index aa7ade821..2d181352f 100644 --- a/src/Dodge/Zone.hs +++ b/src/Dodge/Zone.hs @@ -1,6 +1,7 @@ module Dodge.Zone ( zoneOfSight , zoneAroundPoint + , aroundPoint , nearPoint , wlsNearPoint , crsNearPoint @@ -83,6 +84,11 @@ nearPoint f p w = S.each . fromMaybe mempty $ extractFromZone zn (zoneOfPoint (_ where zn = f w +aroundPoint :: Foldable t => (World -> Zoning t a) -> Point2 -> World -> StreamOf a +aroundPoint f p w = streamFromZone zn $ zoneAroundPoint (_znSize zn) p + where + zn = f w + clsNearPoint :: Point2 -> World -> StreamOf Cloud clsNearPoint = nearPoint _clZoning @@ -95,7 +101,7 @@ crsNearPoint = nearPoint _crZoning nearSeg :: Foldable t => (World -> Zoning t a) -> Point2 -> Point2 -> World -> StreamOf a nearSeg f p r w = streamFromZone zn $ zoneOfSeg (_znSize zn) p r where - zn = (f w) + zn = f w wlsNearSeg :: Point2 -> Point2 -> World -> Stream (Of Wall) Identity () wlsNearSeg = nearSeg _wlZoning diff --git a/src/Dodge/Zone/Size.hs b/src/Dodge/Zone/Size.hs index 16fda43e3..b7f238797 100644 --- a/src/Dodge/Zone/Size.hs +++ b/src/Dodge/Zone/Size.hs @@ -1,5 +1,8 @@ module Dodge.Zone.Size where +phZoneSize :: Float +phZoneSize = 100 + wlZoneSize :: Float wlZoneSize = 50 diff --git a/src/FoldableHelp.hs b/src/FoldableHelp.hs index 4ad1da0ae..e5dff9d2d 100644 --- a/src/FoldableHelp.hs +++ b/src/FoldableHelp.hs @@ -15,7 +15,6 @@ import Data.Foldable import qualified Control.Foldl as L - -- TODO check up whether and how it is necessary to specialise this -- | A version of 'minimum' where the comparison is done on some extracted value. -- Returns Nothing if the list is empty. diff --git a/src/Picture.hs b/src/Picture.hs index d216ec0b4..b83a27345 100644 --- a/src/Picture.hs +++ b/src/Picture.hs @@ -2,372 +2,12 @@ {-# LANGUAGE BangPatterns #-} module Picture ( module Picture.Data + , module Picture.Base + , module Picture.Composite , module Color - , blank - , polygon - , polygonWire - , polygonZ - , polygonCol - , poly3 - , poly3Col - , bezierQuad - , arc - , arcSolid - , thickArc - , thickCircle - , thickLine - , lineThick - , thickLineCol - , circleSolid - , circleSolidCol - , circle - , line - , lineCol - , text - , centerText - , stackText - , pictures - , concatMapPic - , appendPic - , tranRot - , translate - , translate3 - , rotate - , scale - , color - , zeroZ - , setDepth - , addDepth - , setLayer - , mirroryz - , mirrorxz ) where -import Geometry import Picture.Data +import Picture.Base +import Picture.Composite import Color - -blank :: Picture -{-# INLINE blank #-} -blank = [] - -polygonWire :: [Point2] -> Picture -{-# INLINE polygonWire #-} -polygonWire ps = line (ps ++ [head ps]) - --- | Expects clockwise input. -polygon :: [Point2] -> Picture -{-# INLINE polygon #-} -polygon = map f . polyToTris - where - f (V2 x y) = Verx (V3 x y 0) black [] BottomLayer polyNum - -polygonZ :: [Point2] -> Float -> Picture -{-# INLINE polygonZ #-} -polygonZ ps z = map (f . zeroZ) $ polyToTris ps - where - f pos = Verx pos black [z] BottomLayer polyzNum - -polygonCol :: [(Point2,RGBA)] -> Picture -{-# INLINE polygonCol #-} -polygonCol = polyToTris . map f - where - f (V2 x y,col) = Verx (V3 x y 0) col [] BottomLayer polyNum - -poly3 :: [Point3] -> Picture -{-# INLINE poly3 #-} -poly3 = poly3Col . map (, black) - -poly3Col :: [(Point3,RGBA)] -> Picture -{-# INLINE poly3Col #-} -poly3Col = map f . polyToTris - where - f (pos,col) = Verx pos col [] BottomLayer polyNum - --- note that much of work computing the width of the bezier curve is done here -bezierQuad :: Color -> Color -> Float -> Float -> Point2 -> Point2 -> Point2 -> Picture -bezierQuad cola colc ra rc a b c - | a == b && b == c = blank - | a == b || b == c = bezierQuad cola colc ra rc a (0.5 *.* (a +.+ c)) c - | otherwise = bzhelp - [(aIn, cola, V2 (fa aIn) (fc aIn) , V2 1 0 ) - ,(aIn, cola, V2 (fa aIn) (fc aIn) , V2 1 0 ) - ,(cIn, colc, V2 (fa cIn) (fc cIn) , V2 0 1 ) - ,( aX, cola, V2 1 0 , V2 (fa' aX) (fc' aX) ) - ,( cX, colc, V2 0 1 , V2 (fa' cX) (fc' cX) ) - ,( bX, colb, V2 0 0 , V2 (fa' bX) (fc' bX) ) - ,( bX, colb, V2 0 0 , V2 (fa' bX) (fc' bX) ) - ] - where - colb = mixColors 0.5 0.5 cola colc - b2a | isLHS a b c = a -.- b - | otherwise = b -.- a - aRadVec = 0.5 * ra *.* normalizeV (vNormal b2a) - aX = a -.- aRadVec - aIn = a +.+ aRadVec - b2c | isLHS a b c = b -.- c - | otherwise = c -.- b - cRadVec = 0.5 * rc *.* normalizeV (vNormal b2c) - cX = c -.- cRadVec - cIn = c +.+ cRadVec - bRadVec = 0.25 * (ra + rc) *.* normalizeV (a +.+ b -.- 2 *.* c) - bX = b +.+ bRadVec - bIn = b -.- bRadVec - fa = extrapolate aX cX bX - fc = extrapolate cX aX bX - fa' = extrapolate aIn cIn bIn - fc' = extrapolate cIn aIn bIn - -bzhelp :: [(Point2, Point4, Point2, Point2)] -> Picture -bzhelp = map f - where - f (V2 x y,col,V2 a b,V2 c d) = Verx (V3 x y 0) col [a,b,c,d] BottomLayer bezNum - --- given a one and two zeros of a linear function over x and y, --- determine the function --- so if f(ox,oy) = 1 and f(ax,ay) = f(bx,by) = 0, determines f -extrapolate :: Point2 -> Point2 -> Point2 -> Point2 -> Float -extrapolate (V2 ox oy) (V2 ax ay) (V2 bx by) (V2 x y) = - ( x * ( ay - by ) - + y * ( bx - ax ) - + (ax * by - bx * ay) - ) - / - ( ox * ( ay - by ) - + ax * ( by - oy ) - + bx * ( oy - ay ) - ) - -color :: RGBA -> Picture -> Picture -{-# INLINE color #-} -color c = map $ overCol (const c) - -translateH :: Float -> Float -> Point3 -> Point3 -{-# INLINE translateH #-} -translateH !a !b (V3 x y z) = V3 (x+a) (y+b) z - -translate :: Float -> Float -> Picture -> Picture -{-# INLINE translate #-} -translate x = map . overPos . translateH x - -translate3 :: Point3 -> Picture -> Picture -{-# INLINE translate3 #-} -translate3 = map . overPos . (+.+.+) - -tranRot :: V2 Float -> Float -> Picture -> Picture -{-# INLINE tranRot #-} -tranRot (V2 x y) r = map $ overPos (translateH x y . rotate3 r) - -setDepth :: Float -> Picture -> Picture -{-# INLINE setDepth #-} ---setDepth d = map $ second $ overPos (\(x,y,_) -> (x,y,d)) -setDepth d = map $ overPos (\(V3 x y _) -> V3 x y d) - -addDepth :: Float -> Picture -> Picture -{-# INLINE addDepth #-} ---addDepth d = map $ second $ overPos (\(x,y,z) -> (x,y,z+d)) -addDepth d = map $ overPos (\(V3 x y z) -> V3 x y (z+d)) - --- TODO change the Int here to a dedicated type -setLayer :: Layer -> Picture -> Picture -{-# INLINE setLayer #-} -setLayer i = map f - where - f v = v {_vxLayer = i} - -scale3 :: Float -> Float -> Point3 -> Point3 -{-# INLINE scale3 #-} -scale3 a b (V3 x y z) = V3 (x*a) (y*b) z - -scale :: Float -> Float -> Picture -> Picture -{-# INLINE scale #-} -scale x = map . overPos . scale3 x - -rotate :: Float -> Picture -> Picture -{-# INLINE rotate #-} -rotate = map . overPos . rotate3 - -concatMapPic :: Foldable t => (a -> Picture) -> t a -> Picture -{-# INLINE concatMapPic #-} -concatMapPic = concatMap - -appendPic :: Picture -> Picture -> Picture -{-# INLINE appendPic #-} -appendPic = (++) - -pictures :: Foldable t => t Picture -> Picture -{-# INLINABLE pictures #-} -pictures = concat - -makeArc :: Float -> Point2 -> [Point2] -{-# INLINE makeArc #-} -makeArc rad (V2 a b) = map (`rotateV` V2 0 rad) angles - where - angles = [a,a+step.. b] - step = pi * 0.2 - -circleSolid :: Float -> Picture -{-# INLINE circleSolid #-} -circleSolid = circleSolidCol white white - -circleSolidCol :: Color -> Color -> Float -> Picture -{-# INLINE circleSolidCol #-} -circleSolidCol colC colE r = map f - [(V3 (-r) r 0, colC) - ,(V3 (-r) (-r) 0, colE) - ,(V3 r (-r) 0, black) - ] - where - f (pos,col) = Verx pos col [] BottomLayer ellNum - -circle :: Float -> Picture -{-# INLINE circle #-} -circle rad = thickArc 0 (2*pi) rad 1 - -centerText :: String -> Picture -{-# INLINE centerText #-} -centerText s = translate (50 * (negate . fromIntegral $ length s - 1)) 0 $ text s - -stackText :: [String] -> Picture -{-# INLINE stackText #-} -stackText = mconcat . zipWith (\y s -> translate 0 y $ centerText s) [0,100..] - -text :: String -> Picture -{-# INLINE text #-} -text = map f . stringToList - where - f (pos,col,V2 a b) = Verx pos col [a,b] BottomLayer textNum - -line :: [Point2] -> Picture -{-# INLINE line #-} -line = thickLine 1 - -lineCol :: [(Point2,RGBA)] -> Picture -{-# INLINE lineCol #-} -lineCol = thickLineCol 1 - -lineThick :: Float -> [Point2] -> Picture -{-# INLINE lineThick #-} -lineThick t = pictures . f - where - f (x:y:ys) - | x == y = f (x:ys) - | otherwise = polygon [x +.+ n x y, x -.- n x y, y -.- n x y, y +.+ n x y] : f (y:ys) - f _ = [] - n a b = (t*0.5) *.* errorNormalizeV 42 (vNormal (a -.- b)) - -thickLine :: Float -> [Point2] -> Picture -{-# INLINE thickLine #-} -thickLine t = pictures . f - where - f (x:y:ys) - | x == y = f (x:ys) - | otherwise = polygon [x +.+ n, x -.- n, y -.- n, y +.+ n] : f (y:ys) - where - n = (t*0.5) *.* errorNormalizeV 42 (vNormal (x -.- y)) - f _ = [] - -thickLineCol :: Float -> [(Point2,RGBA)] -> Picture -{-# INLINE thickLineCol #-} -thickLineCol t = pictures . f - where - f ((x,c):(y,c'):ys) - | x == y = f ((x,c):ys) - | otherwise = polygonCol - [(x +.+ n x y,c) - ,(x -.- n x y,c) - ,(y -.- n x y,c') - ,(y +.+ n x y,c') - ] : f ((y,c'):ys) - f _ = [] - n a b = (t*0.5) *.* squashNormalizeV (vNormal (a -.- b)) - -thickCircle :: Float -> Float -> Picture -{-# INLINE thickCircle #-} -thickCircle = thickArc 0 (2*pi) - -arcSolid - :: Float -- ^ Start angle - -> Float -- ^ End angle - -> Float -- ^ Radius - -> Picture -{-# INLINE arcSolid #-} -arcSolid startA endA rad = polygon $ V2 0 0 : makeArc rad (V2 startA endA) - -arc - :: Float -- ^ Start angle - -> Float -- ^ End angle - -> Float -- ^ Radius - -> Picture -arc startA endA rad = thickArc startA endA rad 1 -{-# INLINE arc #-} - -thickArc :: Float -> Float -> Float -> Float -> Picture -{-# INLINE thickArc #-} -thickArc startA endA rad wdth - | endA - startA > (pi/ 2) = pictures - [ thickArc (startA + pi/2) endA rad wdth - , thickArcHelp startA (startA + pi/2) r w - ] - | otherwise = thickArcHelp startA endA r w - where - r = rad + 0.5 * wdth - w = 1 - wdth / r - -thickArcHelp :: Float -> Float -> Float -> Float -> Picture -{-# INLINE thickArcHelp #-} -thickArcHelp startA endA rad wdth = map f - [ (V3 0 0 0,black,V3 0 0 wdth) - ,(V3 xa ya 0,black,V3 1 0 wdth) - ,(V3 xb yb 0,black,V3 1 1 wdth) - , (V3 0 0 0,black,V3 0 0 wdth) - ,(V3 xb yb 0,black,V3 1 1 wdth) - ,(V3 xc yc 0,black,V3 0 1 wdth) - ] - where - (V2 xa ya) = rotateV startA (V2 rad 0) - (V2 xb yb) = rotateV (0.5 * (startA + endA)) (V2 (rad * sqrt 2) 0) - --(V2 xb yb) = rotateV (0.5 * (startA + endA)) (V2 (rad * 2) 0) - (V2 xc yc) = rotateV endA (V2 rad 0) - f (pos,col,V3 a b c) = Verx pos col [a,b,c] BottomLayer arcNum - - --- Currently the lens version is much slower -overPos :: (Point3 -> Point3) -> Verx -> Verx -{-# INLINE overPos #-} ---overPos = over vxPos -overPos f vx = vx {_vxPos = f (_vxPos vx)} - -overCol :: (Point4 -> Point4) -> Verx -> Verx -{-# INLINE overCol #-} -overCol f vx = vx {_vxCol = f (_vxCol vx)} - --- no premature optimisation, consider changing to use texture arrays -stringToList :: String -> [(Point3,Point4,Point2)] -{-# INLINE stringToList #-} -stringToList = concatMap (uncurry charToTuple) . zip [0,0.9*dimText ..] - where - dimText = 100 - -charToTuple :: Float -> Char -> [(Point3,Point4,Point2)] -{-# INLINE charToTuple #-} -charToTuple x c = - [(V3 (x-50) (-100) 0, white,V2 offset 1) - ,(V3 (x-50) 100 0, white,V2 offset 0) - ,(V3 (x+50) 100 0, white,V2 (offset+1) 0) - ,(V3 (x-50) (-100) 0, white,V2 offset 1) - ,(V3 (x+50) (-100) 0, white,V2 (offset+1) 1) - ,(V3 (x+50) 100 0, white,V2 (offset+1) 0) - ] - where - offset = fromIntegral (fromEnum c) - 32 - -mirrorxz :: Picture -> Picture -mirrorxz = map (overPos flipy) - where - flipy (V3 x y z) = V3 x (negate y) z - -mirroryz :: Picture -> Picture -mirroryz = map (overPos flipx) - where - flipx (V3 x y z) = V3 (negate x) y z diff --git a/src/Picture/Base.hs b/src/Picture/Base.hs new file mode 100644 index 000000000..b04e5719a --- /dev/null +++ b/src/Picture/Base.hs @@ -0,0 +1,373 @@ +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE BangPatterns #-} +module Picture.Base + ( module Picture.Data + , module Color + , blank + , polygon + , polygonWire + , polygonZ + , polygonCol + , poly3 + , poly3Col + , bezierQuad + , arc + , arcSolid + , thickArc + , thickCircle + , thickLine + , lineThick + , thickLineCol + , circleSolid + , circleSolidCol + , circle + , line + , lineCol + , text + , centerText + , stackText + , pictures + , concatMapPic + , appendPic + , tranRot + , translate + , translate3 + , rotate + , scale + , color + , zeroZ + , setDepth + , addDepth + , setLayer + , mirroryz + , mirrorxz + ) + where +import Geometry +import Picture.Data +import Color + +blank :: Picture +{-# INLINE blank #-} +blank = [] + +polygonWire :: [Point2] -> Picture +{-# INLINE polygonWire #-} +polygonWire ps = line (ps ++ [head ps]) + +-- | Expects clockwise input. +polygon :: [Point2] -> Picture +{-# INLINE polygon #-} +polygon = map f . polyToTris + where + f (V2 x y) = Verx (V3 x y 0) black [] BottomLayer polyNum + +polygonZ :: [Point2] -> Float -> Picture +{-# INLINE polygonZ #-} +polygonZ ps z = map (f . zeroZ) $ polyToTris ps + where + f pos = Verx pos black [z] BottomLayer polyzNum + +polygonCol :: [(Point2,RGBA)] -> Picture +{-# INLINE polygonCol #-} +polygonCol = polyToTris . map f + where + f (V2 x y,col) = Verx (V3 x y 0) col [] BottomLayer polyNum + +poly3 :: [Point3] -> Picture +{-# INLINE poly3 #-} +poly3 = poly3Col . map (, black) + +poly3Col :: [(Point3,RGBA)] -> Picture +{-# INLINE poly3Col #-} +poly3Col = map f . polyToTris + where + f (pos,col) = Verx pos col [] BottomLayer polyNum + +-- note that much of work computing the width of the bezier curve is done here +bezierQuad :: Color -> Color -> Float -> Float -> Point2 -> Point2 -> Point2 -> Picture +bezierQuad cola colc ra rc a b c + | a == b && b == c = blank + | a == b || b == c = bezierQuad cola colc ra rc a (0.5 *.* (a +.+ c)) c + | otherwise = bzhelp + [(aIn, cola, V2 (fa aIn) (fc aIn) , V2 1 0 ) + ,(aIn, cola, V2 (fa aIn) (fc aIn) , V2 1 0 ) + ,(cIn, colc, V2 (fa cIn) (fc cIn) , V2 0 1 ) + ,( aX, cola, V2 1 0 , V2 (fa' aX) (fc' aX) ) + ,( cX, colc, V2 0 1 , V2 (fa' cX) (fc' cX) ) + ,( bX, colb, V2 0 0 , V2 (fa' bX) (fc' bX) ) + ,( bX, colb, V2 0 0 , V2 (fa' bX) (fc' bX) ) + ] + where + colb = mixColors 0.5 0.5 cola colc + b2a | isLHS a b c = a -.- b + | otherwise = b -.- a + aRadVec = 0.5 * ra *.* normalizeV (vNormal b2a) + aX = a -.- aRadVec + aIn = a +.+ aRadVec + b2c | isLHS a b c = b -.- c + | otherwise = c -.- b + cRadVec = 0.5 * rc *.* normalizeV (vNormal b2c) + cX = c -.- cRadVec + cIn = c +.+ cRadVec + bRadVec = 0.25 * (ra + rc) *.* normalizeV (a +.+ b -.- 2 *.* c) + bX = b +.+ bRadVec + bIn = b -.- bRadVec + fa = extrapolate aX cX bX + fc = extrapolate cX aX bX + fa' = extrapolate aIn cIn bIn + fc' = extrapolate cIn aIn bIn + +bzhelp :: [(Point2, Point4, Point2, Point2)] -> Picture +bzhelp = map f + where + f (V2 x y,col,V2 a b,V2 c d) = Verx (V3 x y 0) col [a,b,c,d] BottomLayer bezNum + +-- given a one and two zeros of a linear function over x and y, +-- determine the function +-- so if f(ox,oy) = 1 and f(ax,ay) = f(bx,by) = 0, determines f +extrapolate :: Point2 -> Point2 -> Point2 -> Point2 -> Float +extrapolate (V2 ox oy) (V2 ax ay) (V2 bx by) (V2 x y) = + ( x * ( ay - by ) + + y * ( bx - ax ) + + (ax * by - bx * ay) + ) + / + ( ox * ( ay - by ) + + ax * ( by - oy ) + + bx * ( oy - ay ) + ) + +color :: RGBA -> Picture -> Picture +{-# INLINE color #-} +color c = map $ overCol (const c) + +translateH :: Float -> Float -> Point3 -> Point3 +{-# INLINE translateH #-} +translateH !a !b (V3 x y z) = V3 (x+a) (y+b) z + +translate :: Float -> Float -> Picture -> Picture +{-# INLINE translate #-} +translate x = map . overPos . translateH x + +translate3 :: Point3 -> Picture -> Picture +{-# INLINE translate3 #-} +translate3 = map . overPos . (+.+.+) + +tranRot :: V2 Float -> Float -> Picture -> Picture +{-# INLINE tranRot #-} +tranRot (V2 x y) r = map $ overPos (translateH x y . rotate3 r) + +setDepth :: Float -> Picture -> Picture +{-# INLINE setDepth #-} +--setDepth d = map $ second $ overPos (\(x,y,_) -> (x,y,d)) +setDepth d = map $ overPos (\(V3 x y _) -> V3 x y d) + +addDepth :: Float -> Picture -> Picture +{-# INLINE addDepth #-} +--addDepth d = map $ second $ overPos (\(x,y,z) -> (x,y,z+d)) +addDepth d = map $ overPos (\(V3 x y z) -> V3 x y (z+d)) + +-- TODO change the Int here to a dedicated type +setLayer :: Layer -> Picture -> Picture +{-# INLINE setLayer #-} +setLayer i = map f + where + f v = v {_vxLayer = i} + +scale3 :: Float -> Float -> Point3 -> Point3 +{-# INLINE scale3 #-} +scale3 a b (V3 x y z) = V3 (x*a) (y*b) z + +scale :: Float -> Float -> Picture -> Picture +{-# INLINE scale #-} +scale x = map . overPos . scale3 x + +rotate :: Float -> Picture -> Picture +{-# INLINE rotate #-} +rotate = map . overPos . rotate3 + +concatMapPic :: Foldable t => (a -> Picture) -> t a -> Picture +{-# INLINE concatMapPic #-} +concatMapPic = concatMap + +appendPic :: Picture -> Picture -> Picture +{-# INLINE appendPic #-} +appendPic = (++) + +pictures :: Foldable t => t Picture -> Picture +{-# INLINABLE pictures #-} +pictures = concat + +makeArc :: Float -> Point2 -> [Point2] +{-# INLINE makeArc #-} +makeArc rad (V2 a b) = map (`rotateV` V2 0 rad) angles + where + angles = [a,a+step.. b] + step = pi * 0.2 + +circleSolid :: Float -> Picture +{-# INLINE circleSolid #-} +circleSolid = circleSolidCol white white + +circleSolidCol :: Color -> Color -> Float -> Picture +{-# INLINE circleSolidCol #-} +circleSolidCol colC colE r = map f + [(V3 (-r) r 0, colC) + ,(V3 (-r) (-r) 0, colE) + ,(V3 r (-r) 0, black) + ] + where + f (pos,col) = Verx pos col [] BottomLayer ellNum + +circle :: Float -> Picture +{-# INLINE circle #-} +circle rad = thickArc 0 (2*pi) rad 1 + +centerText :: String -> Picture +{-# INLINE centerText #-} +centerText s = translate (50 * (negate . fromIntegral $ length s - 1)) 0 $ text s + +stackText :: [String] -> Picture +{-# INLINE stackText #-} +stackText = mconcat . zipWith (\y s -> translate 0 y $ centerText s) [0,100..] + +text :: String -> Picture +{-# INLINE text #-} +text = map f . stringToList + where + f (pos,col,V2 a b) = Verx pos col [a,b] BottomLayer textNum + +line :: [Point2] -> Picture +{-# INLINE line #-} +line = thickLine 1 + +lineCol :: [(Point2,RGBA)] -> Picture +{-# INLINE lineCol #-} +lineCol = thickLineCol 1 + +lineThick :: Float -> [Point2] -> Picture +{-# INLINE lineThick #-} +lineThick t = pictures . f + where + f (x:y:ys) + | x == y = f (x:ys) + | otherwise = polygon [x +.+ n x y, x -.- n x y, y -.- n x y, y +.+ n x y] : f (y:ys) + f _ = [] + n a b = (t*0.5) *.* errorNormalizeV 42 (vNormal (a -.- b)) + +thickLine :: Float -> [Point2] -> Picture +{-# INLINE thickLine #-} +thickLine t = pictures . f + where + f (x:y:ys) + | x == y = f (x:ys) + | otherwise = polygon [x +.+ n, x -.- n, y -.- n, y +.+ n] : f (y:ys) + where + n = (t*0.5) *.* errorNormalizeV 42 (vNormal (x -.- y)) + f _ = [] + +thickLineCol :: Float -> [(Point2,RGBA)] -> Picture +{-# INLINE thickLineCol #-} +thickLineCol t = pictures . f + where + f ((x,c):(y,c'):ys) + | x == y = f ((x,c):ys) + | otherwise = polygonCol + [(x +.+ n x y,c) + ,(x -.- n x y,c) + ,(y -.- n x y,c') + ,(y +.+ n x y,c') + ] : f ((y,c'):ys) + f _ = [] + n a b = (t*0.5) *.* squashNormalizeV (vNormal (a -.- b)) + +thickCircle :: Float -> Float -> Picture +{-# INLINE thickCircle #-} +thickCircle = thickArc 0 (2*pi) + +arcSolid + :: Float -- ^ Start angle + -> Float -- ^ End angle + -> Float -- ^ Radius + -> Picture +{-# INLINE arcSolid #-} +arcSolid startA endA rad = polygon $ V2 0 0 : makeArc rad (V2 startA endA) + +arc + :: Float -- ^ Start angle + -> Float -- ^ End angle + -> Float -- ^ Radius + -> Picture +arc startA endA rad = thickArc startA endA rad 1 +{-# INLINE arc #-} + +thickArc :: Float -> Float -> Float -> Float -> Picture +{-# INLINE thickArc #-} +thickArc startA endA rad wdth + | endA - startA > (pi/ 2) = pictures + [ thickArc (startA + pi/2) endA rad wdth + , thickArcHelp startA (startA + pi/2) r w + ] + | otherwise = thickArcHelp startA endA r w + where + r = rad + 0.5 * wdth + w = 1 - wdth / r + +thickArcHelp :: Float -> Float -> Float -> Float -> Picture +{-# INLINE thickArcHelp #-} +thickArcHelp startA endA rad wdth = map f + [ (V3 0 0 0,black,V3 0 0 wdth) + ,(V3 xa ya 0,black,V3 1 0 wdth) + ,(V3 xb yb 0,black,V3 1 1 wdth) + , (V3 0 0 0,black,V3 0 0 wdth) + ,(V3 xb yb 0,black,V3 1 1 wdth) + ,(V3 xc yc 0,black,V3 0 1 wdth) + ] + where + (V2 xa ya) = rotateV startA (V2 rad 0) + (V2 xb yb) = rotateV (0.5 * (startA + endA)) (V2 (rad * sqrt 2) 0) + --(V2 xb yb) = rotateV (0.5 * (startA + endA)) (V2 (rad * 2) 0) + (V2 xc yc) = rotateV endA (V2 rad 0) + f (pos,col,V3 a b c) = Verx pos col [a,b,c] BottomLayer arcNum + + +-- Currently the lens version is much slower +overPos :: (Point3 -> Point3) -> Verx -> Verx +{-# INLINE overPos #-} +--overPos = over vxPos +overPos f vx = vx {_vxPos = f (_vxPos vx)} + +overCol :: (Point4 -> Point4) -> Verx -> Verx +{-# INLINE overCol #-} +overCol f vx = vx {_vxCol = f (_vxCol vx)} + +-- no premature optimisation, consider changing to use texture arrays +stringToList :: String -> [(Point3,Point4,Point2)] +{-# INLINE stringToList #-} +stringToList = concatMap (uncurry charToTuple) . zip [0,0.9*dimText ..] + where + dimText = 100 + +charToTuple :: Float -> Char -> [(Point3,Point4,Point2)] +{-# INLINE charToTuple #-} +charToTuple x c = + [(V3 (x-50) (-100) 0, white,V2 offset 1) + ,(V3 (x-50) 100 0, white,V2 offset 0) + ,(V3 (x+50) 100 0, white,V2 (offset+1) 0) + ,(V3 (x-50) (-100) 0, white,V2 offset 1) + ,(V3 (x+50) (-100) 0, white,V2 (offset+1) 1) + ,(V3 (x+50) 100 0, white,V2 (offset+1) 0) + ] + where + offset = fromIntegral (fromEnum c) - 32 + +mirrorxz :: Picture -> Picture +mirrorxz = map (overPos flipy) + where + flipy (V3 x y z) = V3 x (negate y) z + +mirroryz :: Picture -> Picture +mirroryz = map (overPos flipx) + where + flipx (V3 x y z) = V3 (negate x) y z diff --git a/src/Picture/Composite.hs b/src/Picture/Composite.hs new file mode 100644 index 000000000..b007742fb --- /dev/null +++ b/src/Picture/Composite.hs @@ -0,0 +1,16 @@ +module Picture.Composite where +import Picture.Data +import Picture.Base +import Geometry +--import Color + +arrowPath :: [Point2] -> Picture +arrowPath xs = mconcat $ zipWith arrow xs $ tail xs + +arrow :: Point2 -> Point2 -> Picture +arrow a b = line [a,b] + <> line [b +.+ n -.- v,b] + <> line [b -.- n -.- v,b] + where + v = 5 *.* normalizeV (b -.- a) + n = vNormal v