82 lines
2.1 KiB
Haskell
82 lines
2.1 KiB
Haskell
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 DebugLayer
|
|
. setDepth 20
|
|
. 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
|
|
-> Configuration
|
|
-> World
|
|
-> Picture
|
|
fixedSizePicClamp xbord ybord pic p cfig w
|
|
= setLayer DebugLayer
|
|
. setDepth 20
|
|
. 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 cfig - fromIntegral xbord) / z) xr
|
|
yr' = absClamp ((halfHeight cfig - fromIntegral ybord) / z) yr
|
|
|
|
fixedSizePicClampArrow
|
|
:: Float -- ^ horizontal border
|
|
-> Float -- ^ vertical border
|
|
-> Picture
|
|
-> Point2
|
|
-> Configuration
|
|
-> World
|
|
-> Picture
|
|
fixedSizePicClampArrow xbord ybord pic p cfig w = pictures
|
|
[ setLayer DebugLayer . translate x y . scale theScale theScale $ pic
|
|
, setLayer DebugLayer . color white . setDepth 20 $ arrowPic
|
|
]
|
|
where
|
|
winps = screenPolygon cfig w
|
|
bords = screenPolygonBord xbord ybord cfig w
|
|
borderPoint = intersectSegPolyFirst campos p bords
|
|
windowPoint = intersectSegPolyFirst campos p winps
|
|
arrowPic = case borderPoint of
|
|
Nothing -> blank
|
|
Just bp -> thickLine 5 [bp, fromMaybe p windowPoint]
|
|
(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
|