Mercurial > pub > dyncall > bindings

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