awesome :)
i think you should slow the morphing effect a little bit, and add movement/scrolling :P
looking good, keep up the good work ;)
Some Animated Cloud Action, Improved Again!
-
voodooattack
- Posts: 605
- Joined: Feb 18, 2006 13:30
- Location: Alexandria / Egypt
- Contact:
Already a step ahead of ya! Here it is, sphere mapped instead of ceiling mapped with shadows and a hoirzon(gradient grass/sky), and it scrolls now like real clouds.
http://www.box.net/public/xn7d0ludn2
^^^^download link^^^^
http://www.box.net/public/xn7d0ludn2
^^^^download link^^^^
-
voodooattack
- Posts: 605
- Joined: Feb 18, 2006 13:30
- Location: Alexandria / Egypt
- Contact:
That's pretty neat, keep up the work.
Just an optimization tip though: Instead of using screen pages, create a buffer for the image to be created in. In fullscreen the screen memory is in the video card (assuming a DX backend) and as a result you are doing several slow accesses to the video card. As a buffer, you are creating the image in SRAM which is faster for the CPU to access and the final commit to VRAM can be done in one batch action making it faster.
When I did this from your original code, I got an improvement of ~120 FPS to ~210 FPS.
Just an optimization tip though: Instead of using screen pages, create a buffer for the image to be created in. In fullscreen the screen memory is in the video card (assuming a DX backend) and as a result you are doing several slow accesses to the video card. As a buffer, you are creating the image in SRAM which is faster for the CPU to access and the final commit to VRAM can be done in one batch action making it faster.
When I did this from your original code, I got an improvement of ~120 FPS to ~210 FPS.
Re: Some Animated Cloud Action, Improved Again!
I was looking at this old code because there is a link to it from the wiki (Community Code Library).
My plan was to cleanup the code a bit, add comments, but the code is hard to follow.
This is how far I got (image scaled by 2):
There must be a better way to make nice clouds...
My plan was to cleanup the code a bit, add comments, but the code is hard to follow.
This is how far I got (image scaled by 2):
Code: Select all
'Animated Clouds
Const FinalSZ As Integer = 128
Const IndSZ As Integer = 16 'SZ = size, Ind = ???
Dim Shared As Integer Tile(1 To IndSZ, 1 To IndSZ)
Dim Shared As Integer FinalIMG(1 To FinalSZ, 1 To FinalSZ)
Dim Shared As Integer PT(1 To 4, 1 To 3, 1 To FinalSZ, 1 To FinalSZ) '???
Dim Shared As Integer QuickSelect(1 To 4) = {1, 2, 4, 8}
Sub SmoothNoise()
Dim As Integer x, y
'fill tiles with random values 0...255
For y = 1 To IndSZ
For x = 1 To IndSZ
Tile(x,y) = Int(Rnd * 256) - 128
Next x
Next y
Dim As Integer x1, x2, y1, y2, c, s, m
Dim As Integer Temp(1 To IndSZ, 1 To IndSZ) 'make static? = any?
'smooth tile() to temp()
For y = 1 To IndSZ
If y = 1 Then y1 = IndSZ Else y1 = y - 1 'loop around top/bottom
If y = IndSZ Then y2 = 1 Else y2 = y + 1
For x = 1 To IndSZ
If x = 1 Then x1 = IndSZ Else x1 = x - 1 'loop around left/right
If x = IndSZ Then x2 = 1 Else x2 = x + 1
c = (Tile(x1,y1) + Tile(x2,y1) + Tile(x1,y2) + Tile(x2,y2)) Shr 4 '\16
s = (Tile(x ,y1) + Tile(x2,y ) + Tile(x ,y2) + Tile(x1,y )) Shr 3 '\8
m = Tile(x,y) Shr 2 '\4
Temp(x,y) = c + s + m
Next x
Next y
'copy back to tile
For y = 1 To IndSZ
For x = 1 To IndSZ
Tile(x,y) = Temp(x,y)
Next x
Next y
End Sub
'Tile(,) to PT(,,,)
Sub Resample(Byval tle As Integer, Byval wne As Integer, Byval amt As Double)
Dim As Double fz, fzm, xm, ym, xd, yd, v1, v2, v3, v4, l1, l2
Dim As Integer Temp(1 To FinalSZ, 1 To FinalSZ), x, y, xs, ys, f1
fz = FinalSZ / amt
fzm = IndSZ / fz
ym = 1
For y = 1 To FinalSZ
ym += fzm
If Int(ym) = IndSZ + 1 Then ym = 1
ys = Int(ym)
yd = ym - ys
xm = 1
For x = 1 To FinalSZ
xm += fzm
If Int(xm) = IndSZ + 1 Then xm = 1
xs = Int(xm)
xd = xm - xs
v1 = Tile(xs,ys)
If xs >= IndSZ And ys <> IndSZ Then
v2 = Tile(1 ,ys )
v3 = Tile(1 ,ys+1)
v4 = Tile(xs ,ys+1)
Elseif xs >= IndSZ And ys >= IndSZ Then
v2 = Tile(1 ,ys )
v3 = Tile(1 ,1 )
v4 = Tile(xs ,1 )
Elseif xs <> IndSZ And ys >= IndSZ Then
v2 = Tile(xs+1,ys )
v3 = Tile(xs+1,1 )
v4 = Tile(xs ,1 )
Else
v2 = Tile(xs+1,ys )
v3 = Tile(xs+1,ys+1)
v4 = Tile(xs ,ys+1)
Endif
l1 = (v2-v1) * xd + v1
l2 = (v3-v4) * xd + v4
f1 = (l2-l1) * yd + l1
PT(tle,wne,x,y) = f1
Next x
Next y
End Sub
'???
Sub AddToFinal(Byval tle2 As Integer)
Dim As Integer x, y
For y = 1 To FinalSZ
For x = 1 To FinalSZ
FinalIMG(x,y) += (PT(tle2,3,x,y) / QuickSelect(tle2))
If FinalIMG(x,y) <-128 Then FinalIMG(x,y) =-128
If FinalIMG(x,y) > 127 Then FinalIMG(x,y) = 127
Next x
Next y
End Sub
'Reset the image to 0
Sub ResetFinal()
Dim As Integer x, y
For y = 1 To FinalSZ
For x = 1 To FinalSZ
FinalIMG(x,y) = 0
Next x
Next y
End Sub
'Create exponential color scale
Dim Shared As Integer EX(0 To 255)
Sub Exponential()
Dim As Integer c, d, cv
For cv = 0 To 255
c = cv - 128
If c < 0 Then c = 0
d = 255 - ((0.95^c) * 255)
EX(cv) = d
Next cv
End Sub
'Apply exponential color scale
Sub CreateFinal()
Dim As Integer x, y
For y = 1 To FinalSZ
For x = 1 To FinalSZ
FinalIMG(x,y) = EX(FinalIMG(x,y) + 128)
Next x
Next y
End Sub
'draw image at offset ox,oy
Sub DrawFinal(Byval ox As Integer, Byval oy As Integer)
Dim As Integer x, y, c
For y = 1 To FinalSZ
For x = 1 To FinalSZ
c = FinalIMG(x,y)
'Pset(ox + x, oy + y), Rgb(c, c, c)
line(ox + x shl 1, oy + y shl 1)-step(1, 1), Rgb(c, c, c), bf
Next x
Next y
End Sub
'copy channel2 to channel1
Sub SwapChannels(Byval tle As Integer)
Dim As Integer x, y
For y = 1 To FinalSZ
For x = 1 To FinalSZ
PT(tle,1,x,y) = PT(tle,2,x,y)
Next x
Next y
End Sub
'channel3 = a fraction of channel 1 and 2, set by amt: 0...1
Sub InterpolateChannels(Byval tle As Integer, Byval amt As Double)
Dim As Integer x, y, itf
For y = 1 To FinalSZ
For x = 1 To FinalSZ
PT(tle,3,x,y) = (PT(tle,2,x,y) - PT(tle,1,x,y)) * amt + PT(tle,1,x,y)
Next x
Next y
End Sub
'-------------------------------------------MAIN--------------------------------
Screenres 600, 480, 32
Randomize Timer
Dim As Double iT(1 To 4), iTs(1 To 4) 'times and time steps
Dim As Integer i, speed = 1
Exponential()
'set iT to 100 so it triggers action on first loop
iT(1) = 100: iTs(1)=.001: SmoothNoise(): Resample(1,2,1)
iT(2) = 100: iTs(2)=.002: SmoothNoise(): Resample(2,2,2)
iT(3) = 100: iTs(3)=.005: SmoothNoise(): Resample(3,2,4)
iT(4) = 100: iTs(4)=.010: SmoothNoise(): Resample(4,2,8)
Do
ResetFinal()
If Multikey(&H39) Then speed = 10 Else speed = 1 'spacebar to speed up
For i = 1 To 4
If iT(i) >= 1 Then
iT(i) = 0
SwapChannels(i)
SmoothNoise()
Resample(i, 2, QuickSelect(i))
Else
iT(i) += iTs(i) * speed
InterpolateChannels(i, iT(i))
Endif
AddToFinal(i)
Next i
CreateFinal()
Screenlock
Locate 13,3: Print "FAUX ClOUDS -->"
'Line (155,32)-(284,161),&HFFFF00, B
'Line (156,33)-(283,160),Rgb(100,120,255), B
Line (156,33)-step(FinalSZ*2+1, FinalSZ*2+1), &HFFFF00, B
DrawFinal 155,32
Screenunlock
Sleep 1
Loop Until Multikey(&h01) 'escape to exit
End
Re: Some Animated Cloud Action, Improved Again!
You have an example here: http://abreojosensamblador.epizy.com/?T ... ng=1#Nubes
And a working example of use here: https://board.flatassembler.net/download.php?id=7816
You may move with cursor keys and have a tune in the background
And a working example of use here: https://board.flatassembler.net/download.php?id=7816
You may move with cursor keys and have a tune in the background
Re: Some Animated Cloud Action, Improved Again!
I tried to convert your example (with all windows stuff removed). Not correct yet, but at least displaying something:hurtado wrote:You have an example here: http://abreojosensamblador.epizy.com/?T ... ng=1#Nubes
And a working example of use here: https://board.flatassembler.net/download.php?id=7816
You may move with cursor keys and have a tune in the background
Code: Select all
/' ----------------------------------------------------------------------------
- Plantilla Programación Gráfica - AOWG - Tiny C -
----- -----
- AUTOR : Alfonso Víctor Caballero Hurtado -
----- -----
- VERSION : 1.0 -
----- -----
- (c) 2019. abreojosensamblador.epizy.com -
---------------------------------------------------------------------------- '/
#define cdXSize 320 '//cdYSize*1.6
#define cdYSize 200
#define cdFromColor 1
#define cdToColor 255
type stPaleta
dim as ubyte Azul, Verde, Rojo, Alfa
end type
' Variables globales
dim shared as stPaleta miPaleta(0 to cdToColor)
dim shared as ulong ptr pMainDIB 'any ptr?
dim shared as ubyte mBase(0 to 256 * 256 - 1)
dim shared as integer vdPosX, vdPosY
dim shared as integer mDist(cdYSize \ 2 - 1)
dim shared as integer mAngle(cdYSize \ 2 - 1, cdXSize)
function LeeColorBase(x as ubyte, y as ubyte) as ubyte
return mBase((y shl 8) or x)
end function
sub SetColorBase(x as ubyte, y as ubyte, c as ubyte)
mBase((y shl 8) or x) = c
end sub
sub newColor(x0 as integer, y0 as integer, x as integer, y as integer, x1 as integer, y1 as integer)
dim as integer color_
if LeeColorBase(x,y) = 0 then
color_ = (x1 - x0) + (y1 - y0)
color_ = int(rnd() * (color_ shl 1)) - color_
color_ += (LeeColorBase(x0, y0) + LeeColorBase(x1, y1) + 1) shr 1
if color_ < cdFromColor then color_ = cdFromColor
if color_ > cdToColor then color_ = cdToColor
SetColorBase(x, y, color_)
end if
end sub
sub SubDivide (x0 as integer, y0 as integer, x1 as integer, y1 as integer)
dim as integer x, y, color_
if (x1 - x0 >= 2) or (y1 - y0 >= 2) then
x = (x0 + x1 + 1) shr 1
y = (y0 + y1 + 1) shr 1
NewColor(x0, y0, x, y0, x1, y0)
NewColor(x1, y0, x1, y, x1, y1)
NewColor(x0, y1, x, y1, x1, y1)
NewColor(x0, y0, x0, y, x0, y1)
color_ = (LeeColorBase(x0, y0) + LeeColorBase(x1, y0) _
+ LeeColorBase(x1, y1) + LeeColorBase(x0, y1) + 2) shr 2
SetColorBase(x, y, Color)
SubDivide (x0, y0, x, y)
SubDivide (x, y0, x1, y)
SubDivide (x, y, x1, y1)
SubDivide (x0, y, x, y1)
end if
end sub
sub CreaBase()
clear(@mBase(0), 0, 256 * 256)
mBase(0) = int(rnd() * 226) + 1
SubDivide(0, 0, 256, 256)
end sub
sub CreaPaleta()
dim as ubyte k, r, g, b
dim as integer i, indx, iMedio = (cdToColor + 1) \ 2
miPaleta(0) = type(0, 0, 0, 0)
for i = 1 to iMedio - 1
miPaleta(i).Rojo = (11 + i \ 6) shl 2
miPaleta(i).Verde = (11 + i \ 6) shl 2
miPaleta(i).Azul = (48 + i \ 8) shl 2
miPaleta(i).Alfa = 0
next
for i = iMedio to cdToColor
miPaleta(i).Rojo = i
miPaleta(i).Verde = i
miPaleta(i).Azul = 255
miPaleta(i).Alfa = 0
next
end sub
sub CalcSky(Factor as integer)
dim as integer x, y, color_
for y = 0 to cdYSize \ 2 - 1
mDist(y) = int(log(cdYSize \ 2 - y) * (Factor shr 1))
next
for y = 0 to cdYSize \ 2 - 1
for x = 0 to cdXSize \ 2 -1
color_ = (x * Factor) / (cdXSize / 2 - 1 - y)
mAngle(y, x + cdXSize \ 2) = color_ + Factor
color_ = ((cdXSize \ 2 - 1 - x) * Factor) / (cdXSize \ 2 - 1 - y)
mAngle(y, x) = Factor - color_ - 1
next
next
end sub
sub ShowSkyPixel(px as integer, py as integer)
dim as integer xm, ym
xm = mAngle(py, px) + vdPosX
ym = mDist(py) + vdPosY
'*(pMainDIB + py * cdXSize + px) = *cast(ulong ptr, @miPaleta(LeeColorBase(xm, ym)))
pset(px, py), *cast(ulong ptr, @miPaleta(LeeColorBase(xm, ym)))
end sub
sub PintaObjeto()
dim as integer x, y
for y = 0 to cdYSize \ 2 - 1
for x = 0 to cdXSize - 1
ShowSkyPixel(x, y)
next
next
vdPosX += 1 : vdPosY += 1
end sub
sub Inicio()
CreaBase()
CreaPaleta() 'Creamos la paleta
CalcSky(128) 'Calculamos el array de los índices de la textura del cielo
vdPosX = 0 : vdPosY = 0
end sub
screenres cdXSize, cdYSize, 32
pMainDIB = screenptr
Inicio() 'init
while not inkey = chr(27) 'escape key
screenlock
PintaObjeto()
screenunlock
sleep 20
wend
Edit: see next post.
Last edited by badidea on Jan 12, 2020 19:41, edited 1 time in total.
Re: Some Animated Cloud Action, Improved Again!
You nearly got it
Code: Select all
/' ----------------------------------------------------------------------------
- Plantilla Programación Gráfica - AOWG - Tiny C -
----- -----
- AUTOR : Alfonso Víctor Caballero Hurtado -
----- -----
- VERSION : 1.0 -
----- -----
- (c) 2019. abreojosensamblador.epizy.com -
---------------------------------------------------------------------------- '/
#define cdXSize 320 '//cdYSize*1.6
#define cdYSize 200
#define cdFromColor 1
#define cdToColor 255
type stPaleta
dim as ubyte Azul, Verde, Rojo, Alfa
end type
' Variables globales
dim shared as stPaleta miPaleta(0 to cdToColor+1)
dim shared as ulong ptr pMainDIB 'any ptr?
dim shared as ubyte mBase(0 to 256 * 256 - 1)
dim shared as integer vdPosX, vdPosY
dim shared as integer mDist(cdYSize \ 2 - 1)
dim shared as integer mAngle(cdYSize \ 2 - 1, cdXSize)
function LeeColorBase(x as ubyte, y as ubyte) as ubyte
return mBase((y shl 8) or x)
end function
sub SetColorBase(x as ubyte, y as ubyte, c as ubyte)
mBase((y shl 8) or x) = c
end sub
sub newColor(x0 as integer, y0 as integer, x as integer, y as integer, x1 as integer, y1 as integer)
dim as integer color_
if LeeColorBase(x,y) = 0 then
color_ = (x1 - x0) + (y1 - y0)
color_ = int(rnd() * (color_ shl 1)) - color_
color_ += (LeeColorBase(x0, y0) + LeeColorBase(x1, y1) + 1) shr 1
if color_ < cdFromColor then color_ = cdFromColor
if color_ > cdToColor then color_ = cdToColor
SetColorBase(x, y, color_)
end if
end sub
sub SubDivide (x0 as integer, y0 as integer, x1 as integer, y1 as integer)
dim as integer x, y, color_
if (x1 - x0 >= 2) or (y1 - y0 >= 2) then
x = (x0 + x1 + 1) shr 1
y = (y0 + y1 + 1) shr 1
NewColor(x0, y0, x, y0, x1, y0)
NewColor(x1, y0, x1, y, x1, y1)
NewColor(x0, y1, x, y1, x1, y1)
NewColor(x0, y0, x0, y, x0, y1)
color_ = (LeeColorBase(x0, y0) + LeeColorBase(x1, y0) _
+ LeeColorBase(x1, y1) + LeeColorBase(x0, y1) + 2) shr 2
SetColorBase(x, y, color_)
SubDivide (x0, y0, x, y)
SubDivide (x, y0, x1, y)
SubDivide (x, y, x1, y1)
SubDivide (x0, y, x, y1)
end if
end sub
sub CreaBase()
clear(@mBase(0), 0, 256 * 256)
mBase(0) = int(rnd() * 255) + 1
SubDivide(0, 0, 256, 256)
end sub
sub CreaPaleta()
dim as ubyte k, r, g, b
dim as integer i, indx, iMedio = (cdToColor + 1) \ 2
miPaleta(0) = type(0, 0, 0, 0)
for i = 1 to iMedio - 1
miPaleta(i).Rojo = (11 + i \ 6) shl 2
miPaleta(i).Verde = (11 + i \ 6) shl 2
miPaleta(i).Azul = (48 + i \ 8) shl 2
miPaleta(i).Alfa = 0
next
for i = iMedio to cdToColor
miPaleta(i).Rojo = i
miPaleta(i).Verde = i
miPaleta(i).Azul = 255
miPaleta(i).Alfa = 0
next
end sub
sub CalcSky(Factor as integer)
dim as integer x, y, color_
for y = 0 to cdYSize \ 2 - 1
mDist(y) = int(log(cdYSize \ 2 - y) * (Factor shr 1))
next
for y = 0 to cdYSize \ 2 - 1
for x = 0 to cdXSize \ 2 -1
color_ = (x * Factor) / (cdXSize / 2 - 1 - y)
mAngle(y, x + cdXSize \ 2) = color_ + Factor
color_ = ((cdXSize \ 2 - 1 - x) * Factor) / (cdXSize \ 2 - 1 - y)
mAngle(y, x) = Factor - color_ - 1
next
next
end sub
sub ShowSkyPixel(px as integer, py as integer)
dim as integer xm, ym
xm = mAngle(py, px) + vdPosX
ym = mDist(py) + vdPosY
'*(pMainDIB + py * cdXSize + px) = *cast(ulong ptr, @miPaleta(LeeColorBase(xm, ym)))
pset(px, py), *cast(ulong ptr, @miPaleta(LeeColorBase(xm, ym)))
end sub
sub PintaObjeto()
dim as integer x, y
for y = 0 to cdYSize \ 2 - 1
for x = 0 to cdXSize - 1
ShowSkyPixel(x, y)
next
next
vdPosX += 1 : vdPosY += 1
end sub
sub Inicio()
CreaBase()
CreaPaleta() 'Creamos la paleta
CalcSky(128) 'Calculamos el array de los índices de la textura del cielo
vdPosX = 0 : vdPosY = 0
end sub
screenres cdXSize, cdYSize, 32
pMainDIB = screenptr
Inicio() 'init
while not inkey = chr(27) 'escape key
screenlock
PintaObjeto()
screenunlock
sleep 20
wend
Re: Some Animated Cloud Action, Improved Again!
WinAPI version, previous one has 114Kb compiled, this one 25Kb, not bad.
Code: Select all
/' ----------------------------------------------------------------------------
- Plantilla Programación Gráfica - SWGPTG - FreeBasic -
----- -----
- AUTOR : Alfonso Víctor Caballero Hurtado -
----- -----
- VERSION : 1.0 -
----- -----
- (c) 2020. http://www.abreojosensamblador.net -
- Small Windows Graphics Programming Tutorial With GDI -
---------------------------------------------------------------------------- '/
#include "windows.bi"
#define cdXPos CW_USEDEFAULT
#define cdYPos CW_USEDEFAULT
#define cdXSize 320 '//cdYSize*1.6
#define cdYSize 200
#define cdColFondo 0
#define MAIN_ICON 100 ' // IDI_APPLICATION
#define cdVCursor IDC_ARROW
#define cdVBarTipo 0
#define cdVBtnTipo WS_OVERLAPPEDWINDOW
#define cdIdTimer 1
'#define DIB_RGB_COLORS 0
#define cdFromColor 1
#define cdToColor 255
type stPaleta
dim as ubyte Azul, Verde, Rojo, Alfa
end type
' Prototipos de funciones
Declare Function WndProc (As HWND,As UINT,As WPARAM, As LPARAM) As LRESULT
'// Variables globales
'Dim Shared As Ulong Ptr pMainDIB: pMainDIB =Allocate((cdXSize)*(cdYSize))
Dim Shared As Ulong Ptr pMainDIB
Dim Shared As Integer vdxClient, vdyClient
Dim Shared As BITMAPINFOHEADER bi = Type(Sizeof(BITMAPINFOHEADER),cdXSize,-cdYSize,1,32,0,0,0,0,0,0)
dim shared as stPaleta miPaleta(0 to cdToColor+1)
dim shared as ubyte mBase(0 to 256 * 256 - 1)
dim shared as integer vdPosX, vdPosY
dim shared as integer mDist(cdYSize \ 2 - 1)
dim shared as integer mAngle(cdYSize \ 2 - 1, cdXSize)
function LeeColorBase(x as ubyte, y as ubyte) as ubyte
return mBase((y shl 8) or x)
end function
sub SetColorBase(x as ubyte, y as ubyte, c as ubyte)
mBase((y shl 8) or x) = c
end sub
sub newColor(x0 as integer, y0 as integer, x as integer, y as integer, x1 as integer, y1 as integer)
dim as integer color_
if LeeColorBase(x,y) = 0 then
color_ = (x1 - x0) + (y1 - y0)
color_ = int(rnd() * (color_ shl 1)) - color_
color_ += (LeeColorBase(x0, y0) + LeeColorBase(x1, y1) + 1) shr 1
if color_ < cdFromColor then color_ = cdFromColor
if color_ > cdToColor then color_ = cdToColor
SetColorBase(x, y, color_)
end if
end sub
sub SubDivide (x0 as integer, y0 as integer, x1 as integer, y1 as integer)
dim as integer x, y, color_
if (x1 - x0 >= 2) or (y1 - y0 >= 2) then
x = (x0 + x1 + 1) shr 1
y = (y0 + y1 + 1) shr 1
NewColor(x0, y0, x, y0, x1, y0)
NewColor(x1, y0, x1, y, x1, y1)
NewColor(x0, y1, x, y1, x1, y1)
NewColor(x0, y0, x0, y, x0, y1)
color_ = (LeeColorBase(x0, y0) + LeeColorBase(x1, y0) _
+ LeeColorBase(x1, y1) + LeeColorBase(x0, y1) + 2) shr 2
SetColorBase(x, y, color_)
SubDivide (x0, y0, x, y)
SubDivide (x, y0, x1, y)
SubDivide (x, y, x1, y1)
SubDivide (x0, y, x, y1)
end if
end sub
sub CreaBase()
clear(@mBase(0), 0, 256 * 256)
mBase(0) = int(rnd() * 255) + 1
SubDivide(0, 0, 256, 256)
end sub
sub CreaPaleta()
dim as ubyte k, r, g, b
dim as integer i, indx, iMedio = (cdToColor + 1) \ 2
miPaleta(0) = type(0, 0, 0, 0)
for i = 1 to iMedio - 1
miPaleta(i).Rojo = (11 + i \ 6) shl 2
miPaleta(i).Verde = (11 + i \ 6) shl 2
miPaleta(i).Azul = (48 + i \ 8) shl 2
miPaleta(i).Alfa = 0
next
for i = iMedio to cdToColor
miPaleta(i).Rojo = i
miPaleta(i).Verde = i
miPaleta(i).Azul = 255
miPaleta(i).Alfa = 0
next
end sub
sub CalcSky(Factor as integer)
dim as integer x, y, color_
for y = 0 to cdYSize \ 2 - 1
mDist(y) = int(log(cdYSize \ 2 - y) * (Factor shr 1))
next
for y = 0 to cdYSize \ 2 - 1
for x = 0 to cdXSize \ 2 -1
color_ = (x * Factor) / (cdXSize / 2 - 1 - y)
mAngle(y, x + cdXSize \ 2) = color_ + Factor
color_ = ((cdXSize \ 2 - 1 - x) * Factor) / (cdXSize \ 2 - 1 - y)
mAngle(y, x) = Factor - color_ - 1
next
next
end sub
sub ShowSkyPixel(px as integer, py as integer)
dim as integer xm, ym
xm = mAngle(py, px) + vdPosX
ym = mDist(py) + vdPosY
*(pMainDIB + py * cdXSize + px) = *cast(ulong ptr, @miPaleta(LeeColorBase(xm, ym)))
'pset(px, py), *cast(ulong ptr, @miPaleta(LeeColorBase(xm, ym)))
end sub
sub PintaObjeto()
dim as integer x, y
for y = 0 to cdYSize \ 2 - 1
for x = 0 to cdXSize - 1
ShowSkyPixel(x, y)
next
next
vdPosX += 1 : vdPosY += 1
end sub
sub Inicio()
CreaBase()
CreaPaleta() 'Creamos la paleta
CalcSky(128) 'Calculamos el array de los índices de la textura del cielo
vdPosX = 0 : vdPosY = 0
end sub
Function WndProc(hWnd As HWND, message As UINT, wParam As wPARAM,lParam As LPARAM) As LRESULT
Static As HDC bufDIBDC
Static As HBITMAP hMainDIB
Dim As HDC hdc
Dim As PAINTSTRUCT ps
Static As HGDIOBJ hOldDIB=0, hGDITmp
Dim As Integer bResult
Select Case message
Case WM_CHAR
If (wParam = VK_ESCAPE) Then
SendMessage hWnd, WM_CLOSE, 0, 0
End If
Return 0
Case WM_CREATE:
hdc = GetDC(hWnd)
'// Crea un búfer dib para PintaObjeto. pMainDIB es un puntero a él
bufDIBDC = CreateCompatibleDC (hdc)
hMainDIB = CreateDIBSection(hdc,Cast(Any Ptr, @bi), DIB_RGB_COLORS, @pMainDIB, NULL, 0)
hOldDIB = SelectObject (bufDIBDC, hMainDIB)
ReleaseDC (hWnd, hdc)' // Libera device context
Inicio ()
SetTimer (hWnd, cdIdTimer, 20, NULL)
Return 0
Case WM_TIMER :
PintaObjeto ()
InvalidateRect (hWnd, NULL, FALSE)
Return 0
Case WM_SIZE :
vdxClient = lParam And &hFFFF
vdyClient = lParam Shr &h10 '>>
Return 0
Case WM_PAINT :
hdc = BeginPaint(hWnd, @ps)
'//bResult = BitBlt(hdc, 0, 0, cdXSize, cdYSize, bufDIBDC, 0, 0, SRCCOPY)
bResult = StretchBlt (hdc, 0, 0, vdxClient, vdyClient, bufDIBDC, 0, 0, cdXSize, cdYSize, SRCCOPY)
EndPaint(hWnd, @ps)
Return 0
Case WM_DESTROY
KillTimer (hWnd, cdIdTimer)
hGDITmp = SelectObject (bufDIBDC, hOldDIB)
bResult = DeleteDC (bufDIBDC)
bResult = DeleteObject (hMainDIB)
PostQuitMessage (0)
Return 0
End Select
Return DefWindowProc (hWnd, message, wParam, lParam)
End Function
Function WinMain ( hInstance As HINSTANCE, hPrevInstance As HINSTANCE, _
szCmdLine As pSTR, iCmdShow As Integer) As Integer
Dim As RECT WRect
Static As String szAppName:szAppName = "SWGPTG"
Dim As HWND hWnd
Dim As MSG msg
Dim As WNDCLASS wndclass
wndclass.style = CS_HREDRAW Or CS_VREDRAW
wndclass.lpfnWndProc = @WndProc
wndclass.cbClsExtra = 0
wndclass.cbWndExtra = 0
wndclass.hbrBackground = cdColFondo
wndclass.lpszMenuName = NULL
wndclass.lpszClassName = Strptr(szAppname)
wndclass.hInstance = GetModuleHandle (NULL)
wndclass.hIcon = LoadIcon(hInstance, MAKEINTRESOURCE(MAIN_ICON))
wndclass.hCursor = LoadCursor (NULL, IDC_ARROW)
If RegisterClass (@wndclass) =0 Then
MessageBox (NULL, "This program requires Windows NT!", _
"Error", MB_ICONERROR)
Return 0
End If
SetRect (@WRect, 0, 0, cdXSize, cdYSize)
AdjustWindowRectEx (@WRect, cdVBtnTipo, 0, cdVBarTipo)
WRect.bottom -= WRect.top
WRect.right -= WRect.left
WRect.left = (GetSystemMetrics (SM_CXSCREEN) - WRect.right)/2
WRect.top = (GetSystemMetrics (SM_CYSCREEN) - WRect.bottom) / 3
hWnd = CreateWindowex(0,szAppname ,"Plantilla SWGPTG - (c) abreojosensamblador.net", _
cdVBtnTipo , _
WRect.left,WRect.top,WRect.right,WRect.bottom, _
NULL, NULL, hInstance, NULL)
ShowWindow (hWnd, iCmdShow)
UpdateWindow (hWnd)
While (GetMessage (@msg, NULL, 0, 0))
TranslateMessage (@msg)
DispatchMessage (@msg)
Wend
Return msg.wParam
End Function
winmain(GetModuleHandle( null ), null, Command( ), SW_NORMAL)
Re: Some Animated Cloud Action, Improved Again!
After great contemplation and soul searching, and much pacing up and down, I have arrived at the conclusion that I prefer the GOTO.
Re: Some Animated Cloud Action, Improved Again!
:) Yes. I think that the structure I have created for WinMain and WndProc is solid enough. When I had to decide what to do with wParam == VK_ESCAPE I wonder if I could avoid several cycles skipping a SendMessage and using an stright forward goto. It worked and never got any problem, although I am aware that it is not standard and at some point it may cause a problem, which has not happened so far up today (several years ago) so, when paul doe said he got an exception caused by the goto I thought it might be possible, although it was not the case.
Re: Some Animated Cloud Action, Improved Again!
Hi all
I don't see any GOTO in the code, am I missing something?
I don't see any GOTO in the code, am I missing something?
Re: Some Animated Cloud Action, Improved Again!
This was a previous debate, I have replaced the goto by "SendMessage hWnd, WM_CLOSE, 0, 0"