Code archives/Graphics/Create seamless texture function
This code has been declared by its author to be Public Domain code.
Download source code
| |||||
This is the "create seamless texture function". I made this following the tutorial and code samples by Paul Bourke. http://astronomy.swin.edu.au/~pbourke/ The image doesn't have to be square. :) [ updated: added 2 new Linear methods] | |||||
;=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= ; ; Seamless texture generation Function ; ; by elias_t ; ; Created after a tutorial by Paul Bourke. ; ; updated to make the linear methods work better. ; ;=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= ;example Graphics 640,480,32,2 img=LoadImage("your_image.bmp");your image here ;0=Radial method ;1=Linear 1 method ;2=Linear 2 method seamless=make_seamless(img,0) SaveImage (seamless,"seamless.bmp") TileImage seamless,0,0 ;DrawImage seamless,0,0 Flip WaitKey() End ;************************************************************************* ;needed arrays Dim image(0,0,0) , diagonal(0,0,0) , tile(0,0,0) , mask(0,0) ;img=image handle ;masktype= [0=Radial , 1=Linear] method Function make_seamless(img,masktype) Local a1#,a2#,d# ;protect masktype masktype=Abs(masktype) If masktype>2 Then masktype=2 ;find largest side of the image x=ImageWidth(img) y=ImageHeight(img) ;and resize the image to become square If x<>y If x>y Then N=x If y>x Then N=y ResizeImage img,N,N EndIf If x=y Then N=x Dim image(N,N,2) Dim diagonal(N,N,2) Dim tile(N,N,2) Dim mask(N,N) LockBuffer (ImageBuffer(img)) For j=0 To N-1 For i=0 To N-1 rgb=ReadPixelFast(j,i,ImageBuffer(img)) image(i,j,0) = (rgb Shr 16 And $ff) image(i,j,1) = (rgb Shr 8 And $ff) image(i,j,2) = (rgb And $ff) diagonal ( (i+N/2) Mod N , (j+N/2) Mod N ,0) = image(i,j,0) diagonal ( (i+N/2) Mod N , (j+N/2) Mod N ,1) = image(i,j,1) diagonal ( (i+N/2) Mod N , (j+N/2) Mod N ,2) = image(i,j,2) Next Next UnlockBuffer (ImageBuffer(img)) ;try to make your own masktypes here ;Create the mask For i=0 To N/2-1 For j=0 To N/2-1 Select masktype Case 0;RADIAL d = Sqr((i-N/2)*(i-N/2) + (j-N/2)*(j-N/2)) / (N/2) Case 1;LINEAR 1 If (N/2-i)< (N/2-j) d=Sqr((j-N/2)*(j-N/2))/(N/2) EndIf If (N/2-i)>= (N/2-j) d=Sqr((i-N/2)*(i-N/2) ) /(N/2) EndIf Case 2;LINEAR 2 If (N/2-i)<(N/2-j) d=Sqr((j-N)*(j-N) + (i-N)*(i-N)) / (1.13*N) EndIf If (N/2-i)>=(N/2-j) d=Sqr((i-N)*(i-N) + (j-N)*(j-N)) / (1.13*N) EndIf End Select ;Scale d To range from 1 To 255 d = 255 - (255 * d) If (d < 1) Then d = 1 If (d > 255) Then d = 255 ;Form the mask in Each quadrant mask (i , j ) = d mask (i , N-1-j) = d mask (N-1-i , j ) = d mask (N-1-i , N-1-j) = d Next Next ;Create the tile For j=0 To N-1 For i=0 To N-1 a1 = mask(i,j) a2 = mask( (i+N/2) Mod N , (j+N/2) Mod N ) tile(i,j,0) = a1*image(i,j,0)/(a1+a2) + a2*diagonal(i,j,0)/(a1+a2) tile(i,j,1) = a1*image(i,j,1)/(a1+a2) + a2*diagonal(i,j,1)/(a1+a2) tile(i,j,2) = a1*image(i,j,2)/(a1+a2) + a2*diagonal(i,j,2)/(a1+a2) Next Next ;create the new tileable image img2=CreateImage(N,N) LockBuffer (ImageBuffer(img2)) For j=0 To N-1 For i=0 To N-1 rgb=(tile(i,j,0) Shl 16) + (tile(i,j,1) Shl 8) + tile(i,j,2) WritePixelFast j,i,rgb,ImageBuffer(img2) Next Next UnlockBuffer (ImageBuffer(img2)) Dim image(0,0,0) , diagonal(0,0,0) , tile(0,0,0) , mask(0,0) ;if it wasn't a square image, resize it back to the original scale If x<>y Then ResizeImage img2,x,y Return img2 End Function |
Comments
| ||
THANK YOU SO MUCH. I was actually going to consider buying a seamless texture thing, lol. Ah, the beautiness of the public domain :) |
Code Archives Forum