Add debugging for pathfinding

src/Dodge/Config/Data.hs

@@ -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)

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

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]

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
+    (na,_) <- walkableNodeNear a w
-    nb <- walkableNodeNear b
+    (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 :: Point2 -> World -> Maybe (Int,Point2)
---walkableNodeNear p w = insideCirc
+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

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
+    <> debugDraw cfig w
-    <> drawWallIDs cfig w
+
-    <> drawPathing cfig w
+debugDraw :: Configuration -> World -> Picture
-    <> drawCrInfo cfig w
+debugDraw cfig w = pic
-    <> cfigdraw View_boundaries (const viewBoundaries)
+    <> setLayer FixedCoordLayer (listPicturesAt (0.5*halfWidth cfig) 0 cfig $ map text ts)
-    <> 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)
   where
-    cfigdraw boption draw
+    (ts, pic) = foldMap (f . debugDraw' cfig w) (_debug_booleans cfig)
-        | debugOn boption cfig = draw cfig w
+    f (Left s) = ([s],mempty)
-        | otherwise = 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 
+drawWorldSelect w = setLayer DebugLayer
-    $ line [a,b]
+    $  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,10 +241,7 @@ 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
+drawMousePosition cfig w = setLayer FixedCoordLayer . winScale cfig
-    | not $ debugOn Mouse_position cfig = mempty
-    | otherwise
-        = setLayer FixedCoordLayer . winScale cfig
     . uncurryV translate p
     . scale 0.1 0.1
     . text 
@@ -227,11 +250,8 @@ drawMousePosition cfig w
     p = worldPosToScreen w mwp
     mwp = mouseWorldPos w
 
-drawWallIDs :: Configuration -> World -> Picture
+drawWlIDs :: Configuration -> World -> Picture
-drawWallIDs cfig w 
+drawWlIDs cfig w = setLayer FixedCoordLayer $ foldMap f (_walls w)
-    | debugOn Walls_info cfig = setLayer FixedCoordLayer 
-        $ foldMap f (_walls w)
-    | otherwise = mempty
   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 :: World -> Picture
-drawPathing cfig w
+drawPathing w = setLayer DebugLayer $ 
-    | debugOn Pathing cfig 
-        = 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
+drawCrInfo cfig w = setLayer FixedCoordLayer 
-    | debugOn Cr_status cfig = setLayer FixedCoordLayer 
         $ renderInfoListsAt (2*hw - 400) 0 cfig w
         $ mapMaybe (crDisplayInfo cfig w) $ IM.elems $ _creatures w
-    | otherwise = mempty
   where
     hw = halfWidth cfig
 

src/Dodge/Update.hs

@@ -98,15 +98,26 @@ functionalUpdate cfig w = checkEndGame
     $ updateCloseObjects w
 
 zoneClouds :: World -> World
-zoneClouds w = w & clZoning %~ \zn ->
+zoneClouds w = w 
-    foldl' (flip $ updateZoning (:)) (zn & znObjects .~ mempty) (_clouds 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
+updateWorldSelect w = f . g $ case (w ^? mouseButtons . ix ButtonLeft, w ^? mouseButtons . ix ButtonRight) of
-    Nothing     -> w
+    (Nothing   ,Nothing)  -> w
-    Just False  -> w & wSelect . _1 .~ mouseWorldPos w
+    (Just False,Nothing)  -> w & lLine . _1 .~ mwp
-    Just True   -> w & wSelect . _2 .~ mouseWorldPos w
+    (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'

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

src/Dodge/WorldEvent/ThingsHit.hs

@@ -4,7 +4,6 @@ Find which objects lie upon a line.
  -}
 module Dodge.WorldEvent.ThingsHit
     ( thingsHit
---    , wallsHit
     , thingHit
     , thingsHitExceptCr
     )

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

src/Dodge/Zone/Size.hs

@@ -1,5 +1,8 @@
 module Dodge.Zone.Size where
 
+phZoneSize :: Float
+phZoneSize = 100
+
 wlZoneSize :: Float
 wlZoneSize = 50
 

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.

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

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

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