-
Notifications
You must be signed in to change notification settings - Fork 5
/
test2D.hs
207 lines (179 loc) · 7.77 KB
/
test2D.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
{-# LANGUAGE OverloadedStrings, PackageImports, TypeOperators, DataKinds #-}
import qualified Graphics.UI.GLFW as GLFW
import Control.Applicative hiding (Const)
import Control.Monad
import Data.ByteString.Char8 (ByteString)
import Data.IORef
import Data.Word
import Data.Vect
import Data.Vect.Float.Instances ()
import FRP.Elerea.Param
import qualified Data.ByteString.Char8 as SB
import qualified Data.Trie as T
import qualified Data.Vector.Storable as SV
import System.Environment
import LambdaCube.GL
import Graphics.Rendering.OpenGL.Raw.Core32
import LambdaCube.GL.Mesh
import Codec.Image.STB hiding (Image)
import Math.Noise
import Math.Noise.Modules.Billow
import Data.Maybe
import Data.Bitmap.Pure
import Geometry
import Utility
import Utils
import Blur
import Glow
--import OldFilm
screenQuad :: Exp Obj (FrameBuffer 1 (V4F,V4F))
screenQuad = Accumulate fragCtx PassAll frag rast clear
where
fragCtx = AccumulationContext Nothing $ ColorOp NoBlending (one' :: V4B) :. ColorOp NoBlending (one' :: V4B) :. ZT
clear = FrameBuffer (ColorImage n1 (V4 1 0 0 1):.ColorImage n1 (V4 0 1 0 1):.ZT)
rast = Rasterize triangleCtx prims
prims = Transform vert input
input = Fetch "postSlot" Triangles (IV2F "position")
vert :: Exp V V2F -> VertexOut () V2F
vert uv = VertexOut v4 (Const 1) ZT (NoPerspective uv:.ZT)
where
v4 = pack' $ V4 u v (floatV 1) (floatV 1)
V2 u v = unpack' uv
up = Uni (IFloat "up") :: Exp F Float
down = Uni (IFloat "down")
frag :: Exp F V2F -> FragmentOut (Color V4F :+: Color V4F :+: ZZ)
frag uv' = FragmentOut $ c :. c2 :. ZT
where
c = Cond (down @< r @&& r @< up) (Const (V4 1 0 0 1)) $
Cond (down @< r @&& x @< floatF 128) texel $ pack' $ V4 tR tG tB $ floatF 1--texel2--(Const (V4 0 0 0 1))
c2 = Cond (down @< r @&& r @< up) (Const (V4 1 1 0 1)) $ Const (V4 0 0 0 1)
texel = smp "ScreenQuad" uv
texel2 = smp "ScreenQuad2" uv
V4 r g b a = unpack' texel
V4 x y z w = unpack' fragCoord'
V4 tR _ _ _ = unpack' $ smp "ScreenQuad2" $ uv @+ (Const (V2 0.1 0) :: Exp F V2F) @* up
V4 _ tG _ _ = unpack' $ smp "ScreenQuad2" $ uv @+ (Const (V2 0.11 0) :: Exp F V2F) @* (up @+ r @* floatF 0.1)
V4 _ _ tB _ = unpack' $ smp "ScreenQuad2" $ uv @+ (Const (V2 0.117 0) :: Exp F V2F) @* (up @+ r @* floatF 0.1)
V2 u v = unpack' uv
uv = uv' @* floatF 0.5 @+ floatF 0.5
smp n uv = texture' (Sampler LinearFilter ClampToEdge $ TextureSlot n $ Texture2D (Float RGBA) n1) uv
dummy512 img = renderScreen frag
where
frag :: Exp F V2F -> FragmentOut (Color V4F :+: ZZ)
frag uv = FragmentOut $ smp img uv :. ZT
where
sizeI = 512 :: Word32
smp i coord = texture' (Sampler LinearFilter ClampToEdge $ Texture (Texture2D (Float RGBA) n1) (V2 sizeI sizeI) NoMip [i]) coord
renderRGB :: Exp Obj (FrameBuffer 1 (V4F,V4F,V4F))
renderRGB = Accumulate fragCtx PassAll frag rast clear
where
fragCtx = AccumulationContext Nothing $ ColorOp NoBlending (one' :: V4B):. ColorOp NoBlending (one' :: V4B):.ColorOp NoBlending (one' :: V4B):.ZT
clear = FrameBuffer (ColorImage n1 (V4 0 0 0 1):.ColorImage n1 (V4 0 0 0 1):.ColorImage n1 (V4 0 0 0 1):.ZT)
rast = Rasterize triangleCtx prims
prims = Transform vert input
input = Fetch "ScreenQuad" Triangles (IV2F "position")
vert :: Exp V V2F -> VertexOut () ()
vert uv = VertexOut v4 (Const 1) ZT ZT
where
v4 = pack' $ V4 u v (floatV 1) (floatV 1)
V2 u v = unpack' uv
frag :: Exp F () -> FragmentOut (Color V4F :+: Color V4F :+: Color V4F :+: ZZ)
frag _ = FragmentOut $ Const (V4 1 0 0 1) :. Const (V4 0 1 0 1) :. Const (V4 0 0 1 1) :. ZT
n_time = "time"
main :: IO ()
main = do
let lcnet :: Exp Obj (Image 1 V4F)
lcnet = dummy512 $ fxBlur blur glowImg
--lcnet = fxOldFilm oldFilm { ofTimeLapse = Uni (IFloat n_time) } sceneImg -- $ fxGlow glow sceneImg glowImg
--lcnet = fxBlur blur $ sceneImg
glowImg = dummy512 $ PrjFrameBuffer "" tix0 screenQuad
sceneImg = PrjFrameBuffer "" tix1 screenQuad
(win, windowSize) <- initWindow "LC DSL 2D Demo" 512 512
renderer <- compileRenderer $ ScreenOut lcnet
print $ slotUniform renderer
print $ slotStream renderer
print "renderer created"
initUtility renderer
(mousePosition,mousePositionSink) <- external (0,0)
(fblrPress,fblrPressSink) <- external (False,False,False,False,False)
compiledQuad <- compileMesh quad
obj <- addMesh renderer "postSlot" compiledQuad []
args <- getArgs
let objU = objectUniformSetter obj
slotU = uniformSetter renderer
diffuse = uniformFTexture2D "ScreenQuad" slotU
diffuse2 = uniformFTexture2D "ScreenQuad2" slotU
draw _ = do
render renderer
GLFW.swapBuffers win
GLFW.pollEvents
fname = case args of
[] -> "textures/Panels_Diffuse.png"
n:_ -> n
let p = perlin
clamp :: Double -> Word8
clamp = floor . max 0 . min 255
calc w h i j = (\v -> (v + 1.0) * 127.5 ) $ noiseClampedVal
where
boundBottomX :: Double
boundBottomX = 0.0
boundBottomY :: Double
boundBottomY = 0.0
boundUpperX :: Double
boundUpperX = 10.0
boundUpperY :: Double
boundUpperY = 10.0
xsize = w
ysize = h
xIncrement :: Double
xIncrement = (boundUpperX - boundBottomX) / (fromIntegral xsize)
yIncrement :: Double
yIncrement = (boundUpperY - boundBottomY) / (fromIntegral ysize)
xPos x = ((fromIntegral x) * xIncrement) + boundBottomX
yPos y = ((fromIntegral y) * yIncrement) + boundBottomY
noiseF :: NoiseModule
noiseF = gen perlin { perlinFrequency = 1.1, perlinOctaves = 9 }
--noiseF = gen billow { billowFrequency = 0.6, billowOctaves = 5 }
-- Actual noise computation, getValue returns Maybe Double
noiseValue = fromMaybe (-1.0) $ getValue noiseF (xPos i, yPos j, 2.123)
-- Make sure the noiseValue is in the [-1.0, 1.0] range
noiseClampedVal = if noiseValue > 1.0
then 1.0
else if noiseValue < (-1.0) then (-1.0)
else noiseValue
ch = createSingleChannelBitmap (512,512) Nothing (\i j -> clamp $ calc 512 512 i j)-- $ \x y ->
img = combineChannels [ch,ch,ch] Nothing
diffuse =<< compileTexture2DRGBAF False True img
Right img2 <- loadImage fname
diffuse2 =<< compileTexture2DRGBAF False True img2
s <- fpsState
sc <- start $ do
u <- scene (setScreenSize renderer) slotU objU windowSize mousePosition fblrPress
return $ draw <$> u
driveNetwork sc (readInput win s mousePositionSink fblrPressSink)
dispose renderer
print "renderer destroyed"
GLFW.destroyWindow win
GLFW.terminate
scene :: (Word -> Word -> IO ())
-> T.Trie InputSetter
-> T.Trie InputSetter
-> Signal (Int, Int)
-> Signal (Float, Float)
-> Signal (Bool, Bool, Bool, Bool, Bool)
-> SignalGen Float (Signal ())
scene setSize slotU objU windowSize mousePosition fblrPress = do
time <- stateful 0 (+)
let up = uniformFloat "up" slotU
down = uniformFloat "down" slotU
setTime = uniformFloat n_time slotU
setupGFX (w,h) t' = do
setSize (fromIntegral w) (fromIntegral h)
let s = sin t * 0.5 + 0.5
t = 1.5 * t'
down s
up (s+0.028)
setTime t
return ()
r <- effectful2 setupGFX windowSize time
return r