justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Mid strictifying

Browse Source
This commit is contained in:
jgk
2021-07-29 23:42:27 +02:00
parent 67aa5c05c7
commit bd8ef3f416
22 changed files with 359 additions and 325 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Picture.hs
+59 -58
View File
@@ -63,7 +63,7 @@ import Picture.Data
import Control.Lens
black :: RGBA
black = (0,0,0,1)
black = (V4 0 0 0 1)
--zl :: RenderType -> [(Int,RenderType)]
--zl rt = [(0,rt)]
@@ -84,7 +84,7 @@ polygonCol :: [(Point2,RGBA)] -> Picture
{-# INLINE polygonCol #-}
polygonCol vs = map f $ polyToTris vs
where
f ((x,y),col) = Verx (x,y,0) col PolyV 0
f ((V2 x y),col) = Verx (V3 x y 0) col PolyV 0
poly3 :: [Point3] -> Picture
{-# INLINE poly3 #-}
@@ -103,13 +103,13 @@ bezierQuad cola colc ra rc a b c
| a == b || b == c = bezierQuad cola colc ra rc a (0.5 *.* (a +.+ c)) c
| otherwise = bzhelp
[-- ( (0,0) , cola, (0,0), (0,0) )
(aIn, cola, (fa aIn,fc aIn) , (1,0) )
,(aIn, cola, (fa aIn,fc aIn) , (1,0) )
,(cIn, colc, (fa cIn,fc cIn) , (0,1) )
,( aX, cola, (1,0) , (fa' aX,fc' aX) )
,( cX, colc, (0,1) , (fa' cX,fc' cX) )
,( bX, colb, (0,0) , (fa' bX,fc' bX) )
,( bX, colb, (0,0) , (fa' bX,fc' bX) )
(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
@@ -131,16 +131,16 @@ bezierQuad cola colc ra rc a b c
fa' = extrapolate aIn cIn bIn
fc' = extrapolate cIn aIn bIn
bzhelp :: [(Point2, Point4, (Float, Float), (Float, Float))] -> Picture
bzhelp :: [(Point2, Point4, Point2, Point2)] -> Picture
bzhelp = map f
where
f ((x,y),col,(a,b),(c,d)) = Verx (x,y,0) col (BezV (a,b,c,d)) 0
f ((V2 x y),col,(V2 a b),(V2 c d)) = Verx (V3 x y 0) col (BezV (V4 a b c d)) 0
-- 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 (ox,oy) (ax,ay) (bx,by) (x,y) =
extrapolate (V2 ox oy) (V2 ax ay) (V2 bx by) (V2 x y) =
( x * ( ay - by )
+ y * ( bx - ax )
+ (ax * by - bx * ay)
@@ -157,7 +157,7 @@ color c = map $ overCol (const c)
translate3 :: Float -> Float -> Point3 -> Point3
{-# INLINE translate3 #-}
translate3 a b (x,y,z) = (x+a,y+b,z)
translate3 a b (V3 x y z) = V3 (x+a) (y+b) z
translate :: Float -> Float -> Picture -> Picture
--{-# INLINE translate #-}
@@ -167,12 +167,12 @@ translate x y = map $ overPos (translate3 x y)
setDepth :: Float -> Picture -> Picture
--{-# INLINE setDepth #-}
--setDepth d = map $ second $ overPos (\(x,y,_) -> (x,y,d))
setDepth d = map $ 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 (\(x,y,z) -> (x,y,z+d))
addDepth d = map $ overPos (\(V3 x y z) -> V3 x y (z+d))
setLayer :: Int -> Picture -> Picture
{-# INLINE setLayer #-}
@@ -182,7 +182,7 @@ setLayer i = map f
scale3 :: Float -> Float -> Point3 -> Point3
{-# INLINE scale3 #-}
scale3 a b (x,y,z) = (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 #-}
@@ -197,9 +197,9 @@ pictures :: [Picture] -> Picture
{-# INLINE pictures #-}
pictures = concat
makeArc :: Float -> (Float,Float) -> [Point2]
makeArc :: Float -> Point2 -> [Point2]
{-# INLINE makeArc #-}
makeArc rad (a,b) = map (`rotateV` (0,rad)) angles
makeArc rad (V2 a b) = map (`rotateV` (V2 0 rad)) angles
where
angles = [a,a+step.. b]
step = pi * 0.2
@@ -211,9 +211,9 @@ circleSolid = circleSolidCol white white
circleSolidCol :: Color -> Color -> Float -> Picture
{-# INLINE circleSolidCol #-}
circleSolidCol colC colE r = map f
[( (-r, r,0), colC)
,( (-r,-r,0), colE)
,( ( r,-r,0), black)
[( (V3 (-r) ( r) (0)), colC)
,( (V3 (-r) (-r) (0)), colE)
,( (V3 ( r) (-r) (0)), black)
]
where
f (pos,col) = Verx pos col EllV 0
@@ -273,7 +273,7 @@ arcSolid
-> Float -- ^ Radius
-> Picture
{-# INLINE arcSolid #-}
arcSolid startA endA rad = polygon $ (0,0) : makeArc rad (startA,endA)
arcSolid startA endA rad = polygon $ (V2 0 0) : makeArc rad (V2 startA endA)
arc
:: Float -- ^ Start angle
@@ -297,60 +297,61 @@ thickArc startA endA rad wdth
thickArcHelp :: Float -> Float -> Float -> Float -> [Verx]
thickArcHelp startA endA rad wdth = map f
[( (0,0,0),black,(0,0,wdth))
,((xa,ya,0),black,(1,0,wdth))
,((xb,yb,0),black,(1,1,wdth))
,( (0,0,0),black,(0,0,wdth))
,((xb,yb,0),black,(1,1,wdth))
,((xc,yc,0),black,(0,1,wdth))
[( (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
(xa,ya) = rotateV startA (rad,0)
(xb,yb) = rotateV (0.5 * (startA + endA)) (rad * sqrt 2,0)
(xc,yc) = rotateV endA (rad,0)
(V2 xa ya) = rotateV startA (V2 rad 0)
(V2 xb yb) = rotateV (0.5 * (startA + endA)) (V2 (rad * sqrt 2) (0))
(V2 xc yc) = rotateV endA (V2 rad 0)
f (pos,col,val) = Verx pos col (ArcV val) 0
withAlpha :: Float -> RGBA -> RGBA
{-# INLINE withAlpha #-}
withAlpha a (x,y,z,a') = (x,y,z,a*a')
withAlpha a (V4 x y z a') = (V4 x y z (a*a'))
red,green,blue,yellow,cyan,magenta,rose,violet,azure,aquamarine,chartreuse,orange,white::Color
red = (1,0,0,1)
green = (0,1,0,1)
blue = (0,0,1,1)
yellow = (1,1,0,1)
cyan = (0,1,1,1)
magenta = (1,0,1,1)
rose = (1,0,0.5,1)
violet = (0.5,0,1,1)
azure = (0,0.5,1,1)
aquamarine= (0,1,0.5,1)
chartreuse= (0.5,1,0,1)
orange = (1,0.5,0,1)
white = (1,1,1,1)
red = toV4 (1,0,0,1)
green = toV4 (0,1,0,1)
blue = toV4 (0,0,1,1)
yellow = toV4 (1,1,0,1)
cyan = toV4 (0,1,1,1)
magenta = toV4 (1,0,1,1)
rose = toV4 (1,0,0.5,1)
violet = toV4 (0.5,0,1,1)
azure = toV4 (0,0.5,1,1)
aquamarine= toV4 (0,1,0.5,1)
chartreuse= toV4 (0.5,1,0,1)
orange = toV4 (1,0.5,0,1)
white = toV4 (1,1,1,1)
mixColors :: Float -> Float -> Color -> Color -> Color
mixColors rata ratb (r0,g0,b0,a0) (r2,g2,b2,a2) =
mixColors rata ratb (V4 r0 g0 b0 a0) (V4 r2 g2 b2 a2) =
let fullrat = rata + ratb
normrata = rata / fullrat
normratb = ratb / fullrat
f x y = sqrt $ normrata * x^(2::Int) + normratb * y^(2::Int)
in (f r0 r2 , f g0 g2 , f b0 b2 , normrata * a0 + normratb * a2)
in (V4 (f r0 r2 ) ( f g0 g2 ) ( f b0 b2 ) ( normrata * a0 + normratb * a2))
light :: Color -> Color
light (r,g,b,a) = (r+0.2,g+0.2,b+0.2,a)
light (V4 r g b a) = (V4 (r+0.2) (g+0.2) (b+0.2) (a))
dark :: Color -> Color
dark (r,g,b,a) = (r-0.2,g-0.2,b-0.2,a)
dark (V4 r g b a) = (V4 (r-0.2) (g-0.2) (b-0.2) (a))
dim :: Color -> Color
dim (r,g,b,a) = (r/1.2,g/1.2,b/1.2,a)
dim (V4 r g b a) = (V4 (r/1.2) (g/1.2) (b/1.2) (a))
bright :: Color -> Color
bright (r,g,b,a) = (r*1.2,g*1.2,b*1.2,a)
bright (V4 r g b a) = (V4 (r*1.2) (g*1.2) (b*1.2) (a))
greyN :: Float -> Color
greyN x = (x,x,x,1)
greyN x = toV4 (x,x,x,1)
overPos :: (Point3 -> Point3) -> Verx -> Verx
{-# INLINE overPos #-}
@@ -370,12 +371,12 @@ stringToList s = concatMap (uncurry charToTuple) $ zip [0,0.9*dimText ..] s
charToTuple :: Float -> Char -> [(Point3,Point4,Point2)]
{-# INLINE charToTuple #-}
charToTuple x c =
[((x-50,-100,0), white,(offset,1))
,((x-50,100,0), white,(offset,0))
,((x+50,100,0), white,(offset+1,0))
,((x-50,-100,0), white,(offset,1))
,((x+50,-100,0), white,(offset+1,1))
,((x+50,100,0), white,(offset+1,0))
[((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