-
Notifications
You must be signed in to change notification settings - Fork 1
/
Primitive.hs
273 lines (231 loc) · 8.34 KB
/
Primitive.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
-- |
-- Module : Graphics.Identicon.Primitive
-- Copyright : © 2016–2017 Mark Karpov
-- License : BSD 3 clause
--
-- Maintainer : Mark Karpov <markkarpov92@gmail.com>
-- Stability : experimental
-- Portability : portable
--
-- Various primitives and combinators that help you write code for your
-- identicon. Filling functions is where you start. They create color layers
-- that occupy all available space. If you want to limit a layer in size,
-- specify where this smaller part should be, take a look at the “Position,
-- size, and shape” section. It also contains the 'circle' combinator that
-- limits a given filling is such a way that it forms a circle. Finally, we
-- have combinators that add symmetry to layers and other auxiliary
-- functions.
--
-- As a starting point, here is the function that generates a circle with
-- gradient filling changing from black (on the left hand side) to some
-- color (on the right hand side):
--
-- > f :: Word8 -> Word8 -> Word8 -> Layer
-- > f r g b = circle $ gradientLR id black (PixelRGB8 r g b)
--
-- The function consumes 3 bytes from a hash when it's used in identicon.
module Graphics.Identicon.Primitive
( -- * Filling
black
, color
, gradientLR
, gradientTB
, gradientTLBR
, gradientTRBL
, gradientXY
-- ** Gradient transforming functions
-- $gtrans
, mid
, edge
-- * Position, size, and shape
, onGrid
, circle
-- * Symmetry
, hsym
, vsym
, hvsym
, rsym
-- * Other
, oneof )
where
import Codec.Picture
import Data.Word (Word8)
import Graphics.Identicon
----------------------------------------------------------------------------
-- Filling
-- | Black is a special color, it means absence of light. We give this pixel
-- a name because it's used very frequently in layer coding.
black :: PixelRGB8
black = PixelRGB8 0 0 0
-- | Layer filled with a given color.
color :: PixelRGB8 -> Layer
color a = Layer $ \_ _ _ _ -> a
{-# INLINE color #-}
-- | Gradient changing from left to right.
gradientLR
:: (Float -> Float) -- ^ Gradient transforming function
-> PixelRGB8 -- ^ Left color
-> PixelRGB8 -- ^ Right color
-> Layer
gradientLR f a b = Layer $ \w _ x _ ->
mixWith (const $ ξ f x w) a b
{-# INLINE gradientLR #-}
-- | Gradient changing from top to bottom.
gradientTB
:: (Float -> Float) -- ^ Gradient transforming function
-> PixelRGB8 -- ^ Top color
-> PixelRGB8 -- ^ Bottom color
-> Layer
gradientTB f a b = Layer $ \_ h _ y ->
mixWith (const $ ξ f y h) a b
{-# INLINE gradientTB #-}
-- | Gradient changing from top left corner to bottom right corner.
gradientTLBR
:: (Float -> Float) -- ^ Gradient transforming function
-> PixelRGB8 -- ^ Top left color
-> PixelRGB8 -- ^ Bottom right color
-> Layer
gradientTLBR f a b = Layer $ \w h x y ->
mixWith (const $ ξ f (x + y) (w + h)) a b
{-# INLINE gradientTLBR #-}
-- | Gradient changing from top right corner to bottom left corner.
gradientTRBL
:: (Float -> Float) -- ^ Gradient transforming function
-> PixelRGB8 -- ^ Top right color
-> PixelRGB8 -- ^ Bottom left color
-> Layer
gradientTRBL f a b = Layer $ \w h x y ->
mixWith (const $ ξ f (w - x + y) (w + h)) a b
{-# INLINE gradientTRBL #-}
-- | Gradient with one color everywhere and another in the center.
gradientXY
:: (Float -> Float) -- ^ Gradient transforming function
-> PixelRGB8 -- ^ “Edge” color
-> PixelRGB8 -- ^ Color in the center
-> Layer
gradientXY f a b = Layer $ \w h x y ->
let g x' y' = floor $ (1 - n) * fromIntegral x' + n * fromIntegral y'
n = f (nx * ny)
nx = mid (fromIntegral x / fromIntegral w)
ny = mid (fromIntegral y / fromIntegral h)
in mixWith (const g) a b
{-# INLINE gradientXY #-}
-- | A gradient helper function.
ξ
:: (Float -> Float) -- ^ Gradient transforming function
-> Int -- ^ Actual value of coordinate
-> Int -- ^ Maximum value of coordinate
-> Word8 -- ^ Color at the beginning of the range
-> Word8 -- ^ Color at the end of the range
-> Word8 -- ^ Resulting color
ξ f v l x y = floor $ (1 - n) * fromIntegral x + n * fromIntegral y
where
n = f (fromIntegral v / fromIntegral l)
{-# INLINE ξ #-}
----------------------------------------------------------------------------
-- Gradient transforming functions
-- $gtrans
--
-- A note about “gradient transforming functions”: these normally map value
-- changing from 0 to 1 somehow, but they should not produce values outside
-- of that range. With help of such functions you can change character of
-- gradient transitions considerably.
-- | A built-in gradient transforming function. It maps continuous floating
-- value changing from 0 to 1 to value changing from 0 to 1 (in the middle)
-- and back to 0.
mid :: Float -> Float
mid x = 2 * (if x >= 0.5 then 1.0 - x else x)
{-# INLINE mid #-}
-- | This sharpens gradient transitions.
edge :: Float -> Float
edge x = x * x
{-# INLINE edge #-}
----------------------------------------------------------------------------
-- Position, size, and shape
-- | @onGrid w h n l@, given grid that has @w@ horizontal discrete positions
-- (of equal length) and @h@ vertical positions, it makes given layer @l@
-- occupy cell at index @n@. This approach allows you control position and
-- size at the same time.
--
-- The index @n@ can be greater than maximal index, in this case reminder of
-- division of @n@ by @w * h@ is used.
onGrid :: Integral a
=> Int -- ^ Number of horizontal positions
-> Int -- ^ Number of vertical positions
-> a -- ^ Index of this cell
-> Layer -- ^ Layer to insert
-> Layer -- ^ Resulting layer
onGrid α β n' l = Layer $ \w h x y ->
let n = fromIntegral n' `rem` (α * β)
(y', x') = n `quotRem` α
xu, yu :: Float
xu = fromIntegral w / fromIntegral α
yu = fromIntegral h / fromIntegral β
xA = floor (fromIntegral x' * xu)
xB = floor (fromIntegral (x' + 1) * xu)
yA = floor (fromIntegral y' * yu)
yB = floor (fromIntegral (y' + 1) * yu)
in if x < xA || x >= xB || y < yA || y >= yB
then black
else unLayer l (xB - xA) (yB - yA) (x - xA) (y - yA)
{-# INLINE onGrid #-}
-- | Limit given layer so it forms a circle.
circle :: Layer -> Layer
circle l = Layer $ \w h x y ->
let w', h', v, r0, r1 :: Float
w' = fromIntegral w
h' = fromIntegral h
sqr a = a * a
v = sqr (fromIntegral x - w' / 2) + sqr (fromIntegral y - h' / 2)
r0 = min w' h' / 2
r1 = sqr r0
β = 2.0 * r0
δ = (r1 - v) / β
τ = floor . (* δ) . fromIntegral
~px@(PixelRGB8 r g b) = unLayer l w h x y
e | v < r1 - β = px
| v <= r1 = PixelRGB8 (τ r) (τ g) (τ b)
| otherwise = black
in e
{-# INLINE circle #-}
----------------------------------------------------------------------------
-- Symmetry
-- | Add horizontal symmetry to a layer.
hsym :: Layer -> Layer
hsym l = Layer $ \w h x y ->
let w' = w `quot` 2
in unLayer l w' h (if x > w' then w - x else x) y
{-# INLINE hsym #-}
-- | Add vertical symmetry to a layer.
vsym :: Layer -> Layer
vsym l = Layer $ \w h x y ->
let h' = h `quot` 2
in unLayer l w h' x (if y > h' then h - y else y)
{-# INLINE vsym #-}
-- | Add horizontal and vertical symmetry to layer. Result is a layer with
-- four mirrored repetitions of the same figure.
hvsym :: Layer -> Layer
hvsym l = Layer $ \w h x y ->
let h' = h `quot` 2
w' = w `quot` 2
in unLayer l w' h' (if x > w' then w - x else x)
(if y > h' then h - y else y)
{-# INLINE hvsym #-}
-- | Just like 'hvsym', but every repetition is rotated by 90°. Only works
-- with square layers because for speed it just swaps coordinates.
rsym :: Layer -> Layer
rsym l = Layer $ \w h x y ->
let h' = h `quot` 2
w' = w `quot` 2
α = x > w'
β = y > h'
in unLayer l w' h'
(if α then (if β then w - x else y) else (if β then h - y else x))
(if β then (if α then h - y else x) else (if α then w - x else y))
{-# INLINE rsym #-}
----------------------------------------------------------------------------
-- Other
-- | Select one of provided alternatives given a number.
oneof :: Integral n => [a] -> n -> a
oneof xs n = xs !! (fromIntegral n `rem` length xs)
{-# INLINE oneof #-}