Move towards serializing saves/loads faster

This commit is contained in:
2022-08-19 11:12:43 +01:00
parent c74d3b04bf
commit 9df0fa8692
38 changed files with 542 additions and 384 deletions
+179 -165
View File
@@ -1,56 +1,56 @@
{-# LANGUAGE BangPatterns #-}
{-# 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
, overPos
, picMap
)
where
import Geometry
import Picture.Data
import Color
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,
overPos,
picMap,
) where
import Color
--import qualified Streaming.Prelude as S
import Data.Foldable
import Geometry
import Picture.Data
blank :: Picture
{-# INLINE blank #-}
@@ -74,60 +74,61 @@ polygon = picFormat . 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 = picFormat . map (f . zeroZ) $ polyToTris ps
where
f pos = Verx pos black [z] BottomLayer polyzNum
polygonCol :: [(Point2,RGBA)] -> Picture
polygonCol :: [(Point2, RGBA)] -> Picture
{-# INLINE polygonCol #-}
polygonCol = picFormat . polyToTris . map f
where
f (V2 x y,col) = Verx (V3 x y 0) col [] BottomLayer polyNum
f (V2 x y, col) = Verx (V3 x y 0) col [] BottomLayer polyNum
poly3 :: [Point3] -> Picture
{-# INLINE poly3 #-}
poly3 = poly3Col . map (, black)
poly3 = poly3Col . map (,black)
poly3Col :: [(Point3,RGBA)] -> Picture
poly3Col :: [(Point3, RGBA)] -> Picture
{-# INLINE poly3Col #-}
poly3Col = picFormat . map f . polyToTris
where
f (pos,col) = Verx pos col [] BottomLayer polyNum
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
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
| 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
b2a
| isLHS a b c = a -.- b
| otherwise = b -.- a
aRadVec = 0.5 * ra *.* normalizeV (vNormal b2a)
aX = a -.- aRadVec
aX = a -.- aRadVec
aIn = a +.+ aRadVec
b2c | isLHS a b c = b -.- c
| otherwise = c -.- b
b2c
| isLHS a b c = b -.- c
| otherwise = c -.- b
cRadVec = 0.5 * rc *.* normalizeV (vNormal b2c)
cX = c -.- cRadVec
cX = c -.- cRadVec
cIn = c +.+ cRadVec
bRadVec = 0.25 * (ra + rc) *.* normalizeV (a +.+ b -.- 2 *.* c)
bX = b +.+ bRadVec
bX = b +.+ bRadVec
bIn = b -.- bRadVec
fa = extrapolate aX cX bX
fa = extrapolate aX cX bX
fc = extrapolate cX aX bX
fa' = extrapolate aIn cIn bIn
fc' = extrapolate cIn aIn bIn
@@ -135,22 +136,21 @@ bezierQuad cola colc ra rc a b c
bzhelp :: [(Point2, Point4, Point2, Point2)] -> Picture
bzhelp = picFormat . 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
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 )
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 #-}
@@ -158,7 +158,7 @@ color c = picMap $ overCol (const c)
translateH :: Float -> Float -> Point3 -> Point3
{-# INLINE translateH #-}
translateH !a !b (V3 x y z) = V3 (x+a) (y+b) z
translateH !a !b (V3 x y z) = V3 (x + a) (y + b) z
translate :: Float -> Float -> Picture -> Picture
{-# INLINE translate #-}
@@ -180,18 +180,18 @@ setDepth d = picMap $ 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 = picMap $ overPos (\(V3 x y z) -> V3 x y (z+d))
addDepth d = picMap $ 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 = picMap f
where
f v = v {_vxLayer = i}
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
scale3 a b (V3 x y z) = V3 (x * a) (y * b) z
scale :: Float -> Float -> Picture -> Picture
{-# INLINE scale #-}
@@ -210,14 +210,14 @@ appendPic :: Picture -> Picture -> Picture
appendPic = (<>)
pictures :: Foldable t => t Picture -> Picture
{-# INLINABLE pictures #-}
{-# INLINEABLE pictures #-}
pictures = fold
makeArc :: Float -> Point2 -> [Point2]
{-# INLINE makeArc #-}
makeArc rad (V2 a b) = map (`rotateV` V2 0 rad) angles
where
angles = [a,a+step.. b]
where
angles = [a, a + step .. b]
step = pi * 0.2
circleSolid :: Float -> Picture
@@ -226,103 +226,115 @@ circleSolid = circleSolidCol white white
circleSolidCol :: Color -> Color -> Float -> Picture
{-# INLINE circleSolidCol #-}
circleSolidCol colC colE r = picFormat $ map f
[(V3 (-r) r 0, colC)
,(V3 (-r) (-r) 0, colE)
,(V3 r (-r) 0, black)
]
circleSolidCol colC colE r =
picFormat $
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
f (pos, col) = Verx pos col [] BottomLayer ellNum
circle :: Float -> Picture
{-# INLINE circle #-}
circle rad = thickArc 0 (2*pi) rad 1
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
centerText s = translate (25 + 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..]
stackText = mconcat . zipWith (\y s -> translate 0 y $ centerText s) [0, 100 ..]
text :: String -> Picture
{-# INLINE text #-}
text = picFormat . map f . stringToList
where
f (pos,col,V2 a b) = Verx pos col [a,b] BottomLayer textNum
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
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))
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
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 _ = []
n = (t * 0.5) *.* errorNormalizeV 42 (vNormal (x -.- y))
f _ = []
thickLineCol :: Float -> [(Point2,RGBA)] -> Picture
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))
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)
thickCircle = thickArc 0 (2 * pi)
arcSolid
:: Float -- ^ Start angle
-> Float -- ^ End angle
-> Float -- ^ Radius
-> Picture
arcSolid ::
-- | Start angle
Float ->
-- | End angle
Float ->
-- | Radius
Float ->
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 ::
-- | Start angle
Float ->
-- | End angle
Float ->
-- | Radius
Float ->
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
]
| 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
@@ -330,50 +342,52 @@ thickArc startA endA rad wdth
thickArcHelp :: Float -> Float -> Float -> Float -> Picture
{-# INLINE thickArcHelp #-}
thickArcHelp startA endA rad wdth = picFormat $ 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)
]
thickArcHelp startA endA rad wdth =
picFormat $
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
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)}
overPos f vx = vx{_vxPos = f (_vxPos vx)}
overCol :: (Point4 -> Point4) -> Verx -> Verx
{-# INLINE overCol #-}
overCol f vx = vx {_vxCol = f (_vxCol vx)}
overCol f vx = vx{_vxCol = f (_vxCol vx)}
-- no premature optimisation, consider changing to use texture arrays
stringToList :: String -> [(Point3,Point4,Point2)]
stringToList :: String -> [(Point3, Point4, Point2)]
{-# INLINE stringToList #-}
stringToList = concatMap (uncurry charToTuple) . zip [0,0.9*dimText ..]
stringToList = concatMap (uncurry charToTuple) . zip [0, 0.9 * dimText ..]
where
dimText = 100
charToTuple :: Float -> Char -> [(Point3,Point4,Point2)]
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)
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
where
offset = fromIntegral (fromEnum c) - 32
mirrorxz :: Picture -> Picture