Further strictifying
This commit is contained in:
+28
-30
@@ -51,12 +51,12 @@ drawInventory w = case _inventoryMode w of
|
||||
|
||||
cursorsZ :: World -> Int -> Item -> Picture
|
||||
cursorsZ w ipos it = case it ^? wpAmmo . amParamSel of
|
||||
Nothing -> winScale w $ zDraw sp (155- hw, hh - 77.5)
|
||||
Just jpos -> winScale w $ zDraw sp (155 - hw, hh - (20 * fromIntegral jpos + 77.5))
|
||||
Nothing -> winScale w $ zDraw sp (V2 (155- hw) ( hh - 77.5))
|
||||
Just jpos -> winScale w $ zDraw sp (V2 (155 - hw) ( hh - (20 * fromIntegral jpos + 77.5)))
|
||||
where
|
||||
hh = halfHeight w
|
||||
hw = halfWidth w
|
||||
sp = (125 - hw, hh - (20 * fromIntegral ipos + 17.5))
|
||||
sp = (V2 (125 - hw) ( hh - (20 * fromIntegral ipos + 17.5)))
|
||||
|
||||
topInvCursor :: Color -> Int -> World -> [Picture]
|
||||
topInvCursor col iPos w
|
||||
@@ -84,7 +84,7 @@ mCurs it w = case it ^? wpAmmo . amParamSel of
|
||||
y = 155
|
||||
|
||||
zDraw :: Point2 -> Point2 -> Picture
|
||||
zDraw (x,y) (a,b) = line
|
||||
zDraw (V2 x y) (V2 a b) = line $ map toV2
|
||||
[(x,y)
|
||||
,(0.5 * (x+a), y)
|
||||
,(0.5 * (x+a), b)
|
||||
@@ -97,7 +97,7 @@ pjTweakString pj = _pjDisplayParam pj $ _pjIntParam pj
|
||||
displayMidList :: World -> [String] -> String -> [Picture]
|
||||
displayMidList w strs s =
|
||||
invHead w s
|
||||
++ renderListAt (150,-60) (map (,white) strs) w
|
||||
++ renderListAt (V2 (150) (-60)) (map (,white) strs) w
|
||||
|
||||
invHead :: World -> String -> [Picture]
|
||||
invHead w s = [winScale w . translate (-130) (halfHeight w - 40)
|
||||
@@ -105,10 +105,10 @@ invHead w s = [winScale w . translate (-130) (halfHeight w - 40)
|
||||
]
|
||||
|
||||
displayListTopLeft :: [(String,Color)] -> World -> [Picture]
|
||||
displayListTopLeft = renderListAt (0,0)
|
||||
displayListTopLeft = renderListAt (V2 0 0)
|
||||
|
||||
renderListAt :: Point2 -> [(String,Color)] -> World -> [Picture]
|
||||
renderListAt (tx,ty) scols w =
|
||||
renderListAt (V2 tx ty) scols w =
|
||||
map (winScale w) $ zipWith
|
||||
(translate (tx + 15-halfWidth w))
|
||||
( map (\x -> ty + halfHeight w - (20 * (fromIntegral x+1))) ([0..]::[Int]) )
|
||||
@@ -133,29 +133,29 @@ drawLocations wrld = displayListTopLeft locs wrld
|
||||
locs = map (\(_,s) -> (s,white)) . IM.elems . _seenLocations $ wrld
|
||||
locPoss = map (cartePosToScreen wrld . ($ wrld) . fst) . IM.elems . _seenLocations $ wrld
|
||||
locTexts = map fst locs
|
||||
bFunc (x,y) (z,w) = pictures
|
||||
bFunc (V2 x y) (V2 z w) = pictures
|
||||
[ bline 0.2 0.050 0.010
|
||||
, bline 0.5 0.045 0.005
|
||||
, bline 0.5 0.035 0.002
|
||||
] --cheapo antialiasing
|
||||
where
|
||||
bline alph lwidth rwidth
|
||||
= bezierQuad (withAlpha 0.0 white) (withAlpha alph white) lwidth rwidth (x,y) (0,y) (z,w)
|
||||
= bezierQuad (withAlpha 0.0 white) (withAlpha alph white) lwidth rwidth (V2 x y) (V2 0 y) (V2 z w)
|
||||
|
||||
displayListCoords :: World -> [Point2]
|
||||
displayListCoords w = map (g . f) [(1::Int)..]
|
||||
where
|
||||
f i = ( 15 - halfWidth w , halfHeight w - (20 * fromIntegral i) )
|
||||
g (x,y) = (2*x / getWindowX w, 2*y / getWindowY w)
|
||||
f i = (V2 ( 15 - halfWidth w ) ( halfHeight w - (20 * fromIntegral i)) )
|
||||
g (V2 x y) = (V2 (2*x / getWindowX w) ( 2*y / getWindowY w))
|
||||
|
||||
displayListEndCoords :: World -> [String] -> [Point2]
|
||||
displayListEndCoords w ss = map g $ zipWith h ss $ map f [1..]
|
||||
where
|
||||
f :: Int -> Point2
|
||||
f i = ( 15 - halfWidth w , 2.5 + halfHeight w - (20 * fromIntegral i) )
|
||||
g (x,y) = (2*x / getWindowX w, 2*y / getWindowY w)
|
||||
f i = (V2 ( 15 - halfWidth w ) ( 2.5 + halfHeight w - (20 * fromIntegral i)) )
|
||||
g (V2 x y) = (V2 (2*x / getWindowX w) ( 2*y / getWindowY w))
|
||||
h :: String -> Point2 -> Point2
|
||||
h s (x,y) = (x + 9 * fromIntegral (length s), y)
|
||||
h s (V2 x y) = (V2 (x + 9 * fromIntegral (length s)) ( y))
|
||||
|
||||
--bezierQuad :: Color -> Color -> Float -> Float -> Point2 -> Point2 -> Point2 -> Picture
|
||||
|
||||
@@ -202,18 +202,16 @@ closeObjectTexts w = pictures $ zipWith renderList [(0::Int)..] (map colAndText
|
||||
objPos obj = case obj of Left flit -> _flItPos flit
|
||||
Right bt -> _btPos bt
|
||||
mayScreenPos = mayObj >>= (\theObj -> Just (worldPosToScreen w $ objPos theObj))
|
||||
sc (x, y) = (x*2/getWindowX w, y*2/getWindowY w)
|
||||
sc (V2 x y) = (V2 (x*2/getWindowX w) ( y*2/getWindowY w))
|
||||
maybeLine = do
|
||||
itScreenPos <- mayScreenPos
|
||||
theText <- fmap (snd . colAndText) mayObj
|
||||
let textWidth = 9 * fromIntegral (length theText)
|
||||
let col = maybe white (_itInvColor . _flIt) mayIt
|
||||
let p = (textWidth + xtran 0 + pushout - halfWidth w
|
||||
, halfHeight w - 20* (fromIntegral invPos +1) + 2.5
|
||||
)
|
||||
let p' = ( pushout - halfWidth w + 130
|
||||
, halfHeight w - 20* (fromIntegral invPos +1) + 2.5
|
||||
)
|
||||
let p = V2 (textWidth + xtran 0 + pushout - halfWidth w)
|
||||
( halfHeight w - 20* (fromIntegral invPos +1) + 2.5)
|
||||
let p' = V2 ( pushout - halfWidth w + 130)
|
||||
( halfHeight w - 20* (fromIntegral invPos +1) + 2.5)
|
||||
return $ flip thickLineCol (1 / halfWidth w)
|
||||
[(itScreenPos, withAlpha 0 col)
|
||||
,(sc p' , col)
|
||||
@@ -240,10 +238,10 @@ openCursorAt
|
||||
openCursorAt wth col xoff yoff yint w = winScale w
|
||||
. translate (xoff-halfWidth w) (halfHeight w - (20* fromIntegral yint + yoff) - 20)
|
||||
$ lineCol
|
||||
[(( wth,12.5) ,withAlpha 0 col)
|
||||
,(( 0,12.5) ,col)
|
||||
,(( 0,-7.5) ,col)
|
||||
,(( wth,-7.5) ,withAlpha 0 col)
|
||||
[((V2 wth 12.5) ,withAlpha 0 col)
|
||||
,((V2 0 12.5) ,col)
|
||||
,((V2 ( 0) (-7.5)) ,col)
|
||||
,((V2 ( wth) (-7.5)) ,withAlpha 0 col)
|
||||
]
|
||||
cursorAt
|
||||
:: Float -- ^ Width
|
||||
@@ -257,11 +255,11 @@ cursorAt wth col xoff yoff yint w = winScale w
|
||||
. translate (xoff-halfWidth w) (halfHeight w - (20* fromIntegral yint + yoff) - 20)
|
||||
. color col
|
||||
$ line
|
||||
[( wth,12.5)
|
||||
,( 0,12.5)
|
||||
,( 0,-7.5)
|
||||
,( wth,-7.5)
|
||||
,( wth,12.5)
|
||||
[(V2 wth 12.5)
|
||||
,(V2 0 12.5)
|
||||
,(V2 ( 0) (-7.5))
|
||||
,(V2 ( wth) (-7.5))
|
||||
,(V2 wth 12.5)
|
||||
]
|
||||
|
||||
displayHP :: Int -> World -> Picture
|
||||
|
||||
+16
-16
@@ -50,9 +50,9 @@ fixedCoordPictures w = case _menuLayers w of
|
||||
customMouseCursor :: World -> Picture
|
||||
customMouseCursor w =
|
||||
scale (2 /getWindowX w) (2/ getWindowY w)
|
||||
. uncurry translate (_mousePos w)
|
||||
. uncurryV translate (_mousePos w)
|
||||
. color white
|
||||
$ pictures [ line [(-5,0),(5,0)] , line [(0,-5),(0,5)] ]
|
||||
$ pictures [ line [(V2 (-5) (0)),(V2 5 0)] , line [(V2 (0) (-5)),(V2 0 5)] ]
|
||||
|
||||
testPic :: World -> Picture
|
||||
testPic _ = blank
|
||||
@@ -63,12 +63,12 @@ testPic _ = blank
|
||||
crDraw :: World -> Creature -> Picture
|
||||
crDraw w c = _crPict c c w
|
||||
ppDraw :: PressPlate -> Picture
|
||||
ppDraw c = uncurry translate (_ppPos c) $ rotate (_ppRot c) (_ppPict c)
|
||||
ppDraw c = uncurryV translate (_ppPos c) $ rotate (_ppRot c) (_ppPict c)
|
||||
btDraw :: Button -> Picture
|
||||
btDraw c = uncurry translate (_btPos c) $ rotate (_btRot c) (_btPict c)
|
||||
btDraw c = uncurryV translate (_btPos c) $ rotate (_btRot c) (_btPict c)
|
||||
|
||||
clDraw :: Cloud -> Picture
|
||||
clDraw c = uncurry translate (_clPos c) (_clPict c c)
|
||||
clDraw c = uncurryV translate (_clPos c) (_clPict c c)
|
||||
|
||||
wallFloorsToDraw :: World -> [Wall]
|
||||
wallFloorsToDraw w = filter isVisible $ IM.elems $ wallsOnScreen w
|
||||
@@ -88,15 +88,15 @@ drawWallFloor wl = if _wlIsSeeThrough wl
|
||||
n2 = 15 *.* (vNormal . errorNormalizeVDR $ y -.- x)
|
||||
|
||||
errorNormalizeVDR :: Point2 -> Point2
|
||||
errorNormalizeVDR (0,0) = error "problem with function: errorNormalizeVDR in DodgeRendering"
|
||||
errorNormalizeVDR (V2 0 0) = error "problem with function: errorNormalizeVDR in DodgeRendering"
|
||||
errorNormalizeVDR p = normalizeV p
|
||||
|
||||
printPoint :: Point2 -> Picture
|
||||
printPoint p = color white $ uncurry translate p $ pictures [circle 3 ,scale 0.05 0.05 $ text (show p)]
|
||||
printPoint p = color white $ uncurryV translate p $ pictures [circle 3 ,scale 0.05 0.05 $ text (show p)]
|
||||
|
||||
printRotPoint :: Float -> Point2 -> Picture
|
||||
printRotPoint r p = color white
|
||||
. uncurry translate p
|
||||
. uncurryV translate p
|
||||
$ pictures [circle 3 , rotate (negate r) $ scale 0.1 0.1 $ text (show p)]
|
||||
|
||||
outsideScreenPolygon :: World -> [Point2]
|
||||
@@ -106,10 +106,10 @@ outsideScreenPolygon w = [tr,tl,bl,br]
|
||||
scZoom p | _cameraZoom w /= 0 = (1/_cameraZoom w) *.* p
|
||||
| otherwise = error "Trying to set screen zoom to zero"
|
||||
scTran p = p +.+ _cameraCenter w
|
||||
tr = scTran $ scRot $ scZoom ( 3*halfWidth w , 3* halfHeight w)
|
||||
tl = scTran $ scRot $ scZoom (- (3*halfWidth w), 3* halfHeight w)
|
||||
br = scTran $ scRot $ scZoom ( 3*halfWidth w ,- (3* halfHeight w))
|
||||
bl = scTran $ scRot $ scZoom (- (3*halfWidth w),- (3* halfHeight w))
|
||||
tr = scTran $ scRot $ scZoom $ V2 ( 3*halfWidth w ) ( 3* halfHeight w)
|
||||
tl = scTran $ scRot $ scZoom $ V2 (- (3*halfWidth w)) ( 3* halfHeight w)
|
||||
br = scTran $ scRot $ scZoom $ V2 ( 3*halfWidth w ) (- (3* halfHeight w))
|
||||
bl = scTran $ scRot $ scZoom $ V2 (- (3*halfWidth w)) (- (3* halfHeight w))
|
||||
|
||||
wallShadowsToDraw :: World -> [Wall]
|
||||
wallShadowsToDraw w = filter (fromMaybe True . (^? blVisible))
|
||||
@@ -163,10 +163,10 @@ extendConeToScreenEdge w c (x,y) = orderPolygon $ wallScreenIntersect ++ [x,y] +
|
||||
. makeLoopPairs $ screenPolygon w
|
||||
|
||||
rectangleSolid :: Float -> Float -> Picture
|
||||
rectangleSolid x y = polygon [(x,y),(x,-y),(-x,-y),(-x,y)]
|
||||
rectangleSolid x y = polygon $ map toV2 [(x,y),(x,-y),(-x,-y),(-x,y)]
|
||||
|
||||
drawItem :: FloorItem -> Picture
|
||||
drawItem flit = uncurry translate (_flItPos flit)
|
||||
drawItem flit = uncurryV translate (_flItPos flit)
|
||||
$ rotate (_flItRot flit) (_itFloorPict (_flIt flit))
|
||||
|
||||
|
||||
@@ -212,14 +212,14 @@ wallsAndWindows w
|
||||
(wins,wls) = partition _wlIsSeeThrough . IM.elems $ wallsDoubleScreen w
|
||||
|
||||
wallsToList :: [((Point2,Point2),Point4)] -> [Float]
|
||||
wallsToList = concatMap (\(((a,b),(c,d)),(e,f,g,h)) -> [a,b,c,d,e,f,g,h])
|
||||
wallsToList = concatMap (\(((V2 a b),(V2 c d)),(V4 e f g h)) -> [a,b,c,d,e,f,g,h])
|
||||
|
||||
|
||||
pokeWalls :: Ptr Float -> [((Point2,Point2),Point4)] -> IO Int
|
||||
pokeWalls ptr vals0 = go vals0 0
|
||||
where
|
||||
go [] n = return n
|
||||
go ( (((a,b),(c,d)),(e,f,g,h)):vals) n = do
|
||||
go ( (((V2 a b),(V2 c d)),(V4 e f g h)):vals) n = do
|
||||
pokeElemOff ptr (off 0) a
|
||||
pokeElemOff ptr (off 1) b
|
||||
pokeElemOff ptr (off 2) c
|
||||
|
||||
Reference in New Issue
Block a user