Seasonal Snowflakes

Just starting out? Need help? Post your questions and find answers here.
matalog
Enthusiast
Enthusiast
Posts: 165
Joined: Tue Sep 05, 2017 10:07 am

Seasonal Snowflakes

Post by matalog »

Hi guys,


I have been thinking about plotting some snowflakes over the time off work. They are very interesting, and generally make a decent pattern. I found Reiter's http://patarnott.com/pdf/SnowCrystalGrowth.pdf method which looked decent.

I have coded it, and although it is pretty processor intensive, I wondered if it was possible to make this much faster.


Image

I am not a good programmer, but I can get things done, and they generally work. This does anyway.

Can you think of any ways to make it run faster?

Code: Select all

EnableExplicit

#width = 1000                                                             ; Set Viewing Width
#height = 1000                                                            ; Set Viewing Height
#width1 = 1000                                                            ; Set Final Image Width - This can be greater than Viewing Width
#height1 = 1000                                                           ; Set Final Image Height - This can be greater than Viewing Width

#max=100000000


Dim unreceptivetemp.d(#width1/6,#height1/5)                               ; Setup arrays for the 'points'
Dim receptive.d(#width1/6,#height1/5)
Dim unreceptive.d(#width1/6,#height1/5)
Dim receptivetemp.d(#width1/6,#height1/5)

Global colcho=1
Global r.i,ti.d
ti=0
Global  r=0
Dim ared.i(360)
Dim agreen.i(360)
Dim ablue.i(360)

DataSection                                                           ; Setup Colour Arrays
  Red: 
  Data.i 23,21,20,19,18,17,15,14,13,12,11,11,10,9,8,7,6,6,5,4,4,3,3,2,2,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,2,2,3,3,4,4,5,6,6,7,8,9,10,11,11,12,13,14,15,17,18,19,20,21,23,24,25,27,28,29,31,32,34,35,37,38,40,42,43,45,47,49,50,52,54,56,58,59,61,63,65,67,69,71,73,75,77,79,81,83,85,88,90,92,94,96,98,100,103,105,107,109,111,114,116,118,120,123,125,127,129,131,134,136,138,140,143,145,147,149,151,154,156,158,160,162,164,166,169,171,173,175,177,179,181,183,185,187,189,191,193,195,196,198,200,202,204,205,207,209,211,212,214,216,217,219,220,222,223,225,226,227,229,230,231,233,234,235,236,237,239,240,241,242,243,243,244,245,246,247,248,248,249,250,250,251,251,252,252,253,253,253,254,254,254,254,254,254,254,255,254,254,254,254,254,254,254,253,253,253,252,252,251,251,250,250,249,248,248,247,246,245,244,243,243,242,241,240,239,237,236,235,234,233,231,230,229,227,226,225,223,222,220,219,217,216,214,212,211,209,207,205,204,202,200,198,196,195,193,191,189,187,185,183,181,179,177,175,173,171,169,166,164,162,160,158,156,154,151,149,147,145,143,140,138,136,134,131,129,127,125,123,120,118,116,114,111,109,107,105,103,100,98,96,94,92,90,88,85,83,81,79,77,75,73,71,69,67,65,63,61,59,58,56,54,52,50,49,47,45,43,42,40,38,37,35,34,32,31,29,28,27,25,24
  Green: 
  Data.i 108,106,104,102,101,99,97,96,94,92,90,89,87,85,83,82,80,78,77,75,73,72,70,68,67,65,63,62,60,59,57,55,54,52,51,49,48,46,45,43,42,41,39,38,36,35,34,32,31,30,29,27,26,25,24,23,22,21,20,19,17,17,16,15,14,13,12,11,10,10,9,8,7,7,6,6,5,4,4,3,3,2,2,2,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,2,2,2,3,3,4,4,5,6,6,7,7,8,9,10,10,11,12,13,14,15,16,17,17,19,20,21,22,23,24,25,26,27,29,30,31,32,34,35,36,38,39,41,42,43,45,46,48,49,51,52,54,55,57,59,60,62,63,65,67,68,70,72,73,75,77,78,80,82,83,85,87,89,90,92,94,96,97,99,101,102,104,106,108,109,111,113,115,116,118,120,121,123,125,126,128,130,131,133,135,136,138,139,141,143,144,146,147,149,150,152,153,155,156,157,159,160,162,163,164,166,167,168,169,171,172,173,174,175,176,177,178,179,181,181,182,183,184,185,186,187,188,188,189,190,191,191,192,192,193,194,194,195,195,196,196,196,197,197,197,198,198,198,198,198,198,198,198,199,198,198,198,198,198,198,198,198,197,197,197,196,196,196,195,195,194,194,193,192,192,191,191,190,189,188,188,187,186,185,184,183,182,181,181,179,178,177,176,175,174,173,172,171,169,168,167,166,164,163,162,160,159,157,156,155,153,152,150,149,147,146,144,143,141,139,138,136,135,133,131,130,128,126,125,123,121,120,118,116,115,113,111,109
  Blue: 
  Data.i 124,126,128,131,133,135,137,139,141,143,146,148,150,152,154,156,158,160,162,165,167,169,171,173,175,177,179,181,182,184,186,188,190,192,194,195,197,199,201,202,204,206,207,209,210,212,214,215,217,218,219,221,222,223,225,226,227,228,230,231,232,233,234,235,236,237,238,239,239,240,241,242,242,243,244,244,245,245,246,246,247,247,247,248,248,248,248,248,248,248,249,248,248,248,248,248,248,248,247,247,247,246,246,245,245,244,244,243,242,242,241,240,239,239,238,237,236,235,234,233,232,231,230,228,227,226,225,223,222,221,219,218,217,215,214,212,210,209,207,206,204,202,201,199,197,195,194,192,190,188,186,184,182,181,179,177,175,173,171,169,167,165,162,160,158,156,154,152,150,148,146,143,141,139,137,135,133,131,128,126,124,122,120,117,115,113,111,109,107,105,102,100,98,96,94,92,90,88,86,83,81,79,77,75,73,71,69,67,66,64,62,60,58,56,54,53,51,49,47,46,44,42,41,39,38,36,34,33,31,30,29,27,26,25,23,22,21,20,18,17,16,15,14,13,12,11,10,9,9,8,7,6,6,5,4,4,3,3,2,2,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,2,2,3,3,4,4,5,6,6,7,8,9,9,10,11,12,13,14,15,16,17,18,20,21,22,23,25,26,27,29,30,31,33,34,36,38,39,41,42,44,46,47,49,51,53,54,56,58,60,62,64,66,67,69,71,73,75,77,79,81,83,86,88,90,92,94,96,98,100,102,105,107,109,111,113,115,117,120,122
EndDataSection

Restore Red
For r=1 To 360
  Read.i ared(r)
Next
Restore Green
For r=1 To 360
  Read.i agreen(r)
Next
Restore Blue
For r=1 To 360
  Read.i ablue(r)
Next


#ImgGadget = 0

DataSection                                                             ; Setup hexagonal shape to be drawn at each 'pixel'  - *This may not be necessary at all, at higher resolutions a square shape on hex grid may be fine, not sure.
  Numbers:
  Data.i 2,4,6,6,6,4,2
EndDataSection

; set various variables, some may not be necessary at this stage
Global.d g,z
Global.f d
Global.d t,const,background
Global.i j,count,loops,total,numbers,b,save,wi,he,action,re,gr,bl,col,tot
Global.i x,y,h,v,set,y1,x1,a,lineup,x1s,y1s
save=0

total=0
a=4

x=#width1/2:y=#height1/2

Enumeration                                                               ; More keys than I actually use, but sure, why not.
  #Menu_Escape
  #Menu_Space
  #Menu_W
  #Menu_C
  #Menu_E
  #Menu_P
  #Menu_O
  #Menu_A
EndEnumeration



count=1
wi=#width1/2
he=#height1/2
action=0
tot=0




background=0.4                                                                      ;set background value - all cells will be set to this initially and boundary cells set to this each iteration

For y1=1 To #height1/5
  For x1=1 To #width1/6                                                      ;set background values initial state in this loop
    y=y1*5+a
    z=3*Mod(y,2)
    x=x1*6+4+z
    lineup=Bool(z=0)
    
    unreceptivetemp(x1-lineup,y1)=background
    count=count+1
  Next
Next
receptive(#width1/6/2+1,#height1/5/2)=1                          ;set initial central seed


Procedure SDRAW(image.i)
  
  Shared ared(),ablue(),agreen(),receptive(),receptivetemp(),unreceptive(),unreceptivetemp()          ;set shared arrays
  
  count=0
  
  const=0.001                                                                                         ;set constant value added ot receptive cells each iteration
  
  
  ;Debug col
  
  
  
  
  re=aRed(Int(ti))                                                      ;set colours
  gr=aGreen(Int(ti))
  bl=aBlue(Int(ti))
  col=RGB(re,gr,bl)
  ti=ti+2                                                               ; ti sets the speed of change of colour - Higher = faster, it's a double so decimal numbers are okay.
  If ti>360 
    ti=0
  EndIf
  
  
  Repeat
    
    For y1=2 To #height1/5-2
      For x1=2 To #width1/6-2
        y=y1*5+a                                                ;make hex grid from square grid
        z=3*Mod(y,2)
        x=x1*6+4+z
        lineup=Bool(z=0)
        
        
        If x1<=4 Or x1>=#width1/6-4 Or y1<=4 Or y1>=#height1/5-4               ;  set boundary cells to background value - Not sure about this, but it seems to work until the Snowflake almost touches the walls
          unreceptivetemp(x1,y1)=background
          unreceptivetemp(x1-lineup,y1)=background
          unreceptivetemp(x1-lineup-1,y1)=background
          unreceptivetemp(x1-lineup+1,y1)=background
          unreceptivetemp(x1,y1-1)=background
          unreceptivetemp(x1,y1+1)=background
          unreceptivetemp(x1-1,y1-1)=background
          unreceptivetemp(x1-1,y1+1)=background
        EndIf
        
        
        ;now carryout Iterations - Stage 1
        
        If receptive(x1-lineup,y1)>=1 Or receptive(x1-1-lineup,y1)>=1 Or receptive(x1,y1-1)>=1 Or receptive(x1-1,y1-1)>=1 Or receptive(x1-1,y1+1)>=1 Or receptive(x1+1-lineup,y1)>=1 Or receptive(x1,y1+1)>=1
          unreceptivetemp(x1-lineup,y1)=0
          receptivetemp(x1-lineup,y1)=receptive(x1-lineup,y1)+const
        Else
          receptivetemp(x1-lineup,y1)=0
        EndIf
        
      Next
    Next
    
    
    
    For y1=2 To #height1/5-2
      For x1=2 To #width1/6-2
        y=y1*5+a                                                ;make hex grid from square grid again for stage 2 and plotting
        z=3*Mod(y,2)
        x=x1*6+4+z
        lineup=Bool(z=0)
        
        
        ;Iterations - Stage 2
        
        unreceptive(x1-lineup,y1)=(1/2)*unreceptivetemp(x1-lineup,y1)+(unreceptivetemp(x1-1-lineup,y1)+unreceptivetemp(x1-1,y1-1)+unreceptivetemp(x1-1,y1+1)+unreceptivetemp(x1,y1-1)+unreceptivetemp(x1+1-lineup,y1)+unreceptivetemp(x1,y1+1))/12
        receptive(x1-lineup,y1)=unreceptive(x1-lineup,y1)+receptivetemp(x1-lineup,y1)
        
        If receptive(x1-lineup,y1)>=1
          If Point(x,y)=0
            For h=1 To 7
              Read numbers
              For v=1 To numbers
                Plot (x+v-numbers/2,y+h-7/2,col)
              Next
            Next
            Restore numbers
          EndIf
        EndIf
      Next
    Next
    
    
    CopyArray(unreceptive(),unreceptivetemp())                          
    
    action=action+1
  Until action=10                                                                             ; Run it 10 times to save lag due to image generation
  action=0
  
  
  
  tot=tot+1
EndProcedure


Define.i Event, EventGadget, copy, quit, main, image, imagesc                                 ; Setup up windows and images
main = OpenWindow(#PB_Any, 50, 0, #width-23, #height, "Drawing",#PB_Window_MinimizeGadget)
image = CreateImage(#PB_Any, #width1,#height1) 
ImageGadget(#ImgGadget, 0, 0, #width1, #height1, ImageID(image))
CreateStatusBar(0, WindowID(main))
imagesc = CreateImage(#PB_Any, #width-StatusBarHeight(0),#height-StatusBarHeight(0))
ImageGadget(#ImgGadget, 0, 0, #width-StatusBarHeight(0), #height-StatusBarHeight(0), ImageID(imagesc))


AddKeyboardShortcut(main, #PB_Shortcut_Escape, #Menu_Escape)                            ;  more than I need but I leave them
AddKeyboardShortcut(main, #PB_Shortcut_Space, #Menu_Space)
AddKeyboardShortcut(main, #PB_Shortcut_W, #Menu_W)
AddKeyboardShortcut(main, #PB_Shortcut_C, #Menu_C)
AddKeyboardShortcut(main, #PB_Shortcut_E, #Menu_E)
AddKeyboardShortcut(main, #PB_Shortcut_P, #Menu_P)
AddKeyboardShortcut(main, #PB_Shortcut_O, #Menu_O)
AddKeyboardShortcut(main, #PB_Shortcut_A, #Menu_A)

UseJPEGImageEncoder()

AddWindowTimer(main, 1, 100)

;CreateStatusBar(0, WindowID(main))
AddStatusBarField(130)                                      ; too many here, but I use them elsewhere
AddStatusBarField(130)
AddStatusBarField(130)
AddStatusBarField(130)
AddStatusBarField(130)
AddStatusBarField(130)
AddStatusBarField(130)





Repeat                                                     ; Start main loop
  
  Event = WaitWindowEvent()
  Select Event
    Case #PB_Event_Timer
      Select EventTimer()
        Case 1
          
          StartDrawing(ImageOutput(image))
          DrawingMode(#PB_2DDrawing_Default)
          SDRAW(image)
          StopDrawing()
          
          CopyImage(image, copy)
          ResizeImage(copy, #width-StatusBarHeight(0), #height-StatusBarHeight(0))
          If StartDrawing(ImageOutput(imagesc))
            DrawImage(ImageID(copy), 0, 0)
            StopDrawing()
            ;StatusBarText(0, 0, Str(sides), #PB_StatusBar_Center)
            StatusBarText(0, 1, "tot= "+Str(tot), #PB_StatusBar_Center)
            StatusBarText(0, 2, "count= "+Str(count), #PB_StatusBar_Center)
            StatusBarText(0, 3, "total= "+Str(total), #PB_StatusBar_Center)
            StatusBarText(0, 4, "ti= "+Str(ti), #PB_StatusBar_Center)
            ;StatusBarText(0, 5, "Loops="+Str(tick), #PB_StatusBar_Center)
            ;StatusBarText(0, 6, Str(count), #PB_StatusBar_Center)
            ;tick=tick+1
            SetGadgetState(#ImgGadget, ImageID(imagesc))
            ; Delay(2000)
          EndIf          
      EndSelect
    Case #PB_Event_Menu
      Select EventMenu()
        Case #Menu_C
          x=wi
          y=he
        Case #menu_E
          x=wi+2000
          y=he+2000
        Case #Menu_O
          ; c=0
          ;blackon=600000
        Case #Menu_P
          ; h=100000
        Case #Menu_Escape
          quit = #True
        Case #Menu_Space
          Delay(800)
        Case #Menu_W
          SaveImage(image,"Randraw - "+FormatDate("%yyyy%mm%dd_%hh%ii%ss", Date())+Str(Random(9999,1))+".jpg", #PB_ImagePlugin_JPEG,99)
          StatusBarText(0, 0, "Saved Image " + Str(save), #PB_StatusBar_Right)
          save=save+1
      EndSelect
    Case #PB_Event_Gadget
      EventGadget = EventGadget()
      Select EventGadget        
      EndSelect
    Case #PB_Event_CloseWindow
      Quit=#True
  EndSelect
  
  
  
  
Until quit

Thanks for any help.