Add new files

2021-09-11 12:17:36 +01:00
parent 73beeacf3c
commit 27e4f16dd9
2 changed files with 95 additions and 0 deletions
@@ -0,0 +1,16 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE StrictData #-}
+module Dodge.Bounds
+    where
+import Control.Lens
+
+data Bounds = Bounds
+    { _bdMinX            :: Float
+    , _bdMaxX            :: Float
+    , _bdMinY            :: Float
+    , _bdMaxY            :: Float
+    }
+defaultBounds :: Bounds
+defaultBounds = Bounds 0 0 0 0
+
+makeLenses ''Bounds
@@ -0,0 +1,79 @@
+module Dodge.Picture.SizeInvariant
+    where
+import Dodge.Data
+--import Dodge.Base
+import Dodge.Base.Window
+import Geometry
+import Picture
+
+import Data.Maybe
+
+fixedSizePicAt
+    :: Picture
+    -> Point2
+    -> World
+    -> Picture
+fixedSizePicAt pic p w 
+    = setLayer 4 
+    . setDepth 50 
+    . translate x y 
+    . scale theScale theScale 
+    $ pic 
+  where
+    campos = _cameraViewFrom w
+    v = p -.- campos
+    theScale = 1 / _cameraZoom w
+    (V2 x y) = campos +.+ v
+
+fixedSizePicClamp
+    :: Int      -- ^ horizontal border
+    -> Int      -- ^ vertical border
+    -> Picture
+    -> Point2
+    -> World
+    -> Picture
+fixedSizePicClamp xbord ybord pic p w 
+    = setLayer 4 
+--    . setDepth 50 
+    . translate x y 
+    . scale theScale theScale 
+    $ pic 
+  where
+    r = negate $ _cameraRot w
+    z = _cameraZoom w
+    campos = _cameraViewFrom w
+    v = p -.- campos
+    theScale = 1 / _cameraZoom w
+    (V2 x y) = campos +.+ rotateV (negate r) (V2 xr' yr')
+    (V2 xr yr) = rotateV r v
+    xr' = absClamp ((halfWidth w  - fromIntegral xbord) / z) xr
+    yr' = absClamp ((halfHeight w - fromIntegral ybord) / z) yr
+
+fixedSizePicClampArrow
+    :: Float    -- ^ horizontal border
+    -> Float    -- ^ vertical border
+    -> Picture
+    -> Point2
+    -> World
+    -> Picture
+fixedSizePicClampArrow xbord ybord pic p w = pictures 
+    [ setLayer 4 . translate x y . scale theScale theScale $ pic 
+    , setLayer 4 . color white . setDepth 20 $ arrowPic
+    ]
+  where
+    winps = screenPolygon w
+    bords = screenPolygonBord xbord ybord w
+    borderPoint = intersectSegPolyFirst campos p bords
+    windowPoint = intersectSegPolyFirst campos p winps
+    arrowPic = case borderPoint of
+        Nothing -> blank
+        Just bp -> thickLine [bp, fromMaybe p windowPoint] 5
+    (V2 x y) = fromMaybe p borderPoint
+    campos = _cameraCenter w
+    theScale = 1 / _cameraZoom w
+
+absClamp 
+    :: Float -- ^ clamping value, assumed positive
+    -> Float 
+    -> Float
+absClamp maxVal x = max (negate maxVal) $ min maxVal x