Add debugging for pathfinding
This commit is contained in:
@@ -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)
|
||||
|
||||
+4
-1
@@ -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
|
||||
|
||||
@@ -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]
|
||||
|
||||
+18
-8
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
|
||||
+17
-6
@@ -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'
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -4,7 +4,6 @@ Find which objects lie upon a line.
|
||||
-}
|
||||
module Dodge.WorldEvent.ThingsHit
|
||||
( thingsHit
|
||||
-- , wallsHit
|
||||
, thingHit
|
||||
, thingsHitExceptCr
|
||||
)
|
||||
|
||||
+7
-1
@@ -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
|
||||
|
||||
@@ -1,5 +1,8 @@
|
||||
module Dodge.Zone.Size where
|
||||
|
||||
phZoneSize :: Float
|
||||
phZoneSize = 100
|
||||
|
||||
wlZoneSize :: Float
|
||||
wlZoneSize = 50
|
||||
|
||||
|
||||
@@ -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.
|
||||
|
||||
+4
-364
@@ -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
|
||||
|
||||
@@ -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
|
||||
@@ -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
|
||||
Reference in New Issue
Block a user