Mercurial > pub > dyncall > bindings

comparison R/rdyncall/demo/randomfield2.R @ 0:0cfcc391201f

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
initial from svn dyncall-1745
author Daniel Adler
date Thu, 19 Mar 2015 22:26:28 +0100
parents
children
comparison
equal deleted inserted replaced
-1:000000000000 0:0cfcc391201f
1 # Package: rdyncall
2 # File: demo/randomfield.R
3 # Description: Scientific Computations using OpenGL: Rendering 512x512 random field by blending 5000 point sprites (dynport demo)
4 require(rdyncall)
5 library(lattice)
6 dynport(SDL)
7 dynport(GL)
8
9 # ----------------------------------------------------------------------------
10 # Parameters:
11
12 # Framebuffer size
13 fb.size <- 512
14
15 # Texture size
16 tex.size <- 512
17
18 # Blending color
19 colorunit <- 0.02
20
21 # ----------------------------------------------------------------------------
22 # texture setup
23
24 genTex.circle <- function(n)
25 {
26 m <- matrix(data=FALSE,nr=n,nc=n)
27 r <- n/2
28 for(i in 1:n)
29 {
30 for(j in 1:n)
31 {
32 m[[i,j]] <- ifelse((i-r)^2+(j-r)^2 > r^2,0L,255L)
33 }
34 }
35 return(m)
36 }
37
38 genTex.bnorm <- function(n)
39 {
40 x <- seq(-3,3,len=n)
41 y <- dnorm(x)
42 return( outer(y,y) )
43 }
44
45 # ----------------------------------------------------------------------------
46 # draw circle using OpenGL Vertex Arrays
47
48 drawTexCirclesVertexArray <- function(x,y,r)
49 {
50 n <- max( length(x), length(y), length(r) )
51 x1 <- x-r
52 x2 <- x+r
53 y1 <- y-r
54 y2 <- y+r
55
56 vertexArray <- as.vector(rbind(x1,y1,x2, y1, x2, y2, x1, y2))
57 texCoordArray <- rep( as.double(c(0,0,1,0,1,1,0,1)), n )
58
59 glEnableClientState(GL_VERTEX_ARRAY)
60 glEnableClientState(GL_TEXTURE_COORD_ARRAY)
61 glVertexPointer(2,GL_DOUBLE,0,vertexArray)
62 glTexCoordPointer(2,GL_DOUBLE,0,texCoordArray)
63
64 glDrawArrays(GL_QUADS, 0, n*4)
65
66 glDisableClientState(GL_VERTEX_ARRAY)
67 glDisableClientState(GL_TEXTURE_COORD_ARRAY)
68 }
69
70 #drawPointSprite <- function()
71 #{
72 # glEnable(GL_POINT_SPRITE)
73 # glTexEnvi(GL_POINT_SPRITE,GL_COORD_REPLACE,GL_TRUE)
74 # glPointParameter(GL_POINT_SPRITE_COORD_ORIGIN, GL_LOWER_LEFT)
75 # glPointSize
76 #}
77
78 # ----------------------------------------------------------------------------
79 # initialize SDL, OpenGL
80
81 max.tex.size <- integer(1)
82 max.tex.units <- integer(1)
83 tex.ids <- integer(1)
84
85 init <- function()
86 {
87 # initialize SDL
88
89 SDL_Init(SDL_INIT_VIDEO)
90 surface <<- SDL_SetVideoMode(fb.size,fb.size,32,SDL_OPENGL+SDL_DOUBLEBUF)
91
92 # initialize OpenGL
93
94 glGetIntegerv(GL_MAX_TEXTURE_SIZE, max.tex.size)
95 glGetIntegerv(GL_MAX_TEXTURE_UNITS, max.tex.units)
96
97 glClearColor(0,0,0,0)
98 glColor4f(0.1,0.1,0.1,0)
99
100 # img <- genTex.circle(tex.size)
101 # texdata <- as.raw(img)
102
103 img <- genTex.bnorm(tex.size)
104 m <- max(img)
105 texdata <- as.raw( ( img/m ) * 255 )
106
107
108 glGenTextures( length(tex.ids),tex.ids)
109 glBindTexture(GL_TEXTURE_2D, tex.ids[[1]])
110 glPixelStorei(GL_UNPACK_ALIGNMENT, 1)
111 glTexImage2D(GL_TEXTURE_2D, 0, GL_ALPHA, tex.size, tex.size, 0, GL_ALPHA, GL_UNSIGNED_BYTE, texdata)
112 # glTexImage2D(GL_TEXTURE_2D, 0, GL_ALPHA, tex.size, tex.size, 0, GL_ALPHA, GL_DOUBLE, as.vector(img))
113
114 glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_S,GL_CLAMP_TO_BORDER)
115 glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_T,GL_CLAMP_TO_BORDER)
116 glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_NEAREST)
117 glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_NEAREST)
118
119 glTexEnvi(GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE)
120 glEnable(GL_TEXTURE_2D)
121
122 # blending setup
123
124 glBlendFunc(GL_SRC_ALPHA, GL_ONE)
125 glEnable(GL_BLEND)
126
127 glColor3d( colorunit,colorunit,colorunit )
128
129 }
130
131 cleanup <- function()
132 {
133 glDeleteTextures( length(tex.ids), tex.ids)
134 SDL_Quit()
135 }
136
137 sim <- function(N = 5000)
138 return(list(
139 x = runif(N,-1.1,+1.1),
140 y = runif(N,-1.1,+1.1),
141 r = runif(N, 0.1, 0.2)
142 ))
143
144 render <- function(o) {
145 glClear(GL_COLOR_BUFFER_BIT)
146 drawTexCirclesVertexArray(o$x,o$y,o$r)
147 glFinish()
148 SDL_GL_SwapBuffers()
149 }
150
151 event <- new.struct("SDL_Event")
152 quit <- FALSE
153 pollEvents <- function() {
154 while( SDL_PollEvent(event) != 0 )
155 {
156 type <- event$type
157 if (type == SDL_MOUSEBUTTONDOWN) {
158 cat("Read pixels via OpenGL into an R integer matrix..")
159 pixels <<- readpixels()
160 cat("done.\nPlot image results with R plotting device. This may take a while - please be patient..")
161 image(pixels)
162 cat("done.\nContinue..\n")
163 } else if (type == SDL_QUIT) {
164 cat("Read pixels via OpenGL into an R integer matrix 'pixels'..")
165 pixels <<- readpixels()
166 cat("done.\nRe-run by 'run()'\n")
167 quit <<- TRUE
168 }
169 }
170 }
171
172 # --- Read Pixels ------------------------------------------------------------
173
174 readpixels <- function()
175 {
176 array <- matrix(NA_integer_,fb.size,fb.size)
177 glPixelStorei(GL_PACK_ALIGNMENT,1)
178 glReadPixels(0,0,fb.size,fb.size, GL_LUMINANCE, GL_INT, array)
179 return(array)
180 }
181
182
183 # --- FPS Counter ------------------------------------------------------------
184
185 fpsInit <- function()
186 return(list(
187 tbase = SDL_GetTicks(),
188 frames = 0
189 ))
190
191 fpsUpdate <- function(o) {
192 tnow <- SDL_GetTicks()
193 if ((tnow - o$tbase) > 1000)
194 {
195 o$tbase <- tnow
196 SDL_WM_SetCaption(paste("FPS:", o$frames),NULL)
197 o$frames <- 0
198 } else {
199 o$frames <- o$frames + 1
200 }
201 return(o)
202 }
203
204 # --- Main Loop --------------------------------------------------------------
205
206 main <- function()
207 {
208 init()
209 # disable interactive plot device.
210 oldpars <- par(ask=FALSE,mfrow=c(1,1))
211 # user notice
212 cat("Click on window to import current random field and plot in R.\nClose window to quit mainloop.\n")
213
214 fps <- fpsInit()
215 quit <<- FALSE
216 while(!quit)
217 {
218 sim <- sim(5000)
219 render(sim)
220 pollEvents()
221 fps <- fpsUpdate(fps)
222 }
223
224 par(oldpars)
225 }
226
227 main()
228