Some Animated Cloud Action, Improved Again!

Post your FreeBASIC tips and tricks here. Please don’t post your code without including an explanation.
voodooattack
Posts: 605
Joined: Feb 18, 2006 13:30
Location: Alexandria / Egypt
Contact:

Postby voodooattack » Dec 31, 2006 21:21

awesome :)

i think you should slow the morphing effect a little bit, and add movement/scrolling :P

looking good, keep up the good work ;)
Zamaster
Posts: 1024
Joined: Jun 20, 2005 21:40
Contact:

Postby Zamaster » Dec 31, 2006 21:32

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^^^^
voodooattack
Posts: 605
Joined: Feb 18, 2006 13:30
Location: Alexandria / Egypt
Contact:

Postby voodooattack » Dec 31, 2006 21:45

I like it a lot, especially the shadow effects :)
1000101
Posts: 2556
Joined: Jun 13, 2005 23:14
Location: SK, Canada

Postby 1000101 » Dec 31, 2006 23:00

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.
Zamaster
Posts: 1024
Joined: Jun 20, 2005 21:40
Contact:

Postby Zamaster » Jan 01, 2007 0:25

Thanks, thats actually gonna help everything else Ive ever done with screen pages.

Im thinking about making a raycaster and putting something like this in it.
Zamaster
Posts: 1024
Joined: Jun 20, 2005 21:40
Contact:

Postby Zamaster » Jan 01, 2007 0:50

okay, fixed:

http://www.box.net/public/xn7d0ludn2

^^^^download link^^^^
badidea
Posts: 1766
Joined: May 24, 2007 22:10
Location: The Netherlands

Re: Some Animated Cloud Action, Improved Again!

Postby badidea » Jan 12, 2020 1:39

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):

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

There must be a better way to make nice clouds...
hurtado
Posts: 47
Joined: Apr 26, 2017 8:57
Contact:

Re: Some Animated Cloud Action, Improved Again!

Postby hurtado » Jan 12, 2020 3:26

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
badidea
Posts: 1766
Joined: May 24, 2007 22:10
Location: The Netherlands

Re: Some Animated Cloud Action, Improved Again!

Postby badidea » Jan 12, 2020 13:38

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

I tried to convert your example (with all windows stuff removed). Not correct yet, but at least displaying something:

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.
hurtado
Posts: 47
Joined: Apr 26, 2017 8:57
Contact:

Re: Some Animated Cloud Action, Improved Again!

Postby hurtado » Jan 12, 2020 15:37

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
hurtado
Posts: 47
Joined: Apr 26, 2017 8:57
Contact:

Re: Some Animated Cloud Action, Improved Again!

Postby hurtado » Jan 12, 2020 15:45

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)
dodicat
Posts: 6139
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Some Animated Cloud Action, Improved Again!

Postby dodicat » Jan 12, 2020 16:06

After great contemplation and soul searching, and much pacing up and down, I have arrived at the conclusion that I prefer the GOTO.
hurtado
Posts: 47
Joined: Apr 26, 2017 8:57
Contact:

Re: Some Animated Cloud Action, Improved Again!

Postby hurtado » Jan 12, 2020 16:23

:) 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.
srvaldez
Posts: 2216
Joined: Sep 25, 2005 21:54

Re: Some Animated Cloud Action, Improved Again!

Postby srvaldez » Jan 12, 2020 17:11

Hi all
I don't see any GOTO in the code, am I missing something?
hurtado
Posts: 47
Joined: Apr 26, 2017 8:57
Contact:

Re: Some Animated Cloud Action, Improved Again!

Postby hurtado » Jan 12, 2020 17:26

This was a previous debate, I have replaced the goto by "SendMessage hWnd, WM_CLOSE, 0, 0"

Return to “Tips and Tricks”

Who is online

Users browsing this forum: No registered users and 2 guests