GFA Wild Geometry: Lot of sliders to create geometric figure

[scalion]

Hello all,
it's a little demo with proc using static variables for progressive rendering. I hope you will like it.

Just to see what he do : Here the setup (made with inno setup) : setupGfaWildGeometryV1.exe (678.72 KB)

And here the code To hack and tinker :

App.Name = "Gfa Wild Geometry V1.0"
Global Large APA
Global Large Afi = 0
Global Dim z() As Double
Global Double Zmax
DefTypes
Global CreatingPic As TYPE_CreatingPic
Global BIH As BITMAPINFOHEADER
Global Long imMemSize, hbm, imAdr, i, imCol = 16777215
Global Long imW = 512, imH = 512, x, y
Global Double RapWH
Global Picture MyPic, PicPotar
Global Double t1
DefaultCreatingPic

ReDim z(imW, imH)
APA = imW
Do
 Inc APA
Loop Until IsPrime(APA) = True
Afi = 0
Global Large AfpStop
AfpStop = imW * imH + 1
RapWH = imW / imH

Form GfaBGCreator
GfaBGCreator.FullW
Global Dim PotarNAme(20) As String
DefPotars
GfaBGCreator.BackColor = colBtnFace
GfaBGCreator.AutoRedraw = 1
Ocx Image Render
Render.BorderStyle = 1
Render.Move 10, 10, Render.Parent.ScaleWidth / 2, Render.Parent.ScaleHeight - 20
Render.Stretch = 1
ResizeRender
Void SetForegroundWindow(GfaBGCreator.hWnd)

Ocx Command PicCopy = "COPY"
PicCopy.Visible = False
Ocx Command PicSave = "SAVE"
PicCopy.Visible = False
Ocx Command PicRandom = "RANDOM"
PicRandom.Visible = False

GfaBGCreator_ReSize

Do
 RenduProgressif False
 For i = 1 To 1000
   AffichageProgressif
 Next i
 PeekEvent
Loop Until Me Is Nothing
Proc imColor(r%, g%, b%)
 imCol = RGB(b, g, r)
EndProc
Proc imCircle(x%, y%, r%)
 
 Local Long Afx, AFy, rr
 
 rr = r * r
 For Afx = 0 To  Int(r / 1.414213562373) + 1
   AFy = Sqr(rr - (Afx * Afx))
   imPlot x + Afx, y + AFy
   imPlot x + Afx, y - AFy
   imPlot x - Afx, y + AFy
   imPlot x - Afx, y - AFy
   imPlot x + AFy, y + Afx
   imPlot x + AFy, y - Afx
   imPlot x - AFy, y + Afx
   imPlot x - AFy, y - Afx
 Next Afx
 
EndProc
Proc imPlot(x%, y%)
 Local Long Offset
 If x >= 0
   If x < imW
     If y >= 0
       If y < imH
         y = Pred(imH) - y
         Offset = 4 * (x + (y * imW))
         LPoke imAdr + Offset, imCol
       EndIf
     EndIf
   EndIf
 EndIf
 
EndProc
Sub Potar_MouseMove(Index%, Button&, Shift&, x!, y!)
 If Button > 0
   Label(Index) = PotarNAme(Index) & Potar(Index).Value
 EndIf
EndSub
Sub Potar_Change(Index%)
 Label(Index) = PotarNAme(Index) & Potar(Index).Value
 GetPotarsValues
 If Index >= 9 And Index <= 11
 Else If Index = 12 Or Index = 13
   ResizeRender
   RenduProgressif True
 Else
   RenduProgressif True
 EndIf
 'StartRender
 'EndIf
EndSub
Sub GfaBGCreator_MouseMove(Button&, Shift&, x!, y!)
 If !IsNothing(PicCopy) PicCopy.Visible = False
 If !IsNothing(PicSave) PicSave.Visible = False
 If !IsNothing(PicRandom) PicRandom.Visible = False
EndSub
Sub GfaBGCreator_ReSize
 Local Long w, h, i, x, y
 
 If !IsNothing(Render)
   
   w = Render.Parent.ScaleWidth / 2 - 20
   h = w / RapWH
   If h > Render.Parent.ScaleHeight - 20
     h = Render.Parent.ScaleHeight - 20
     w = h * RapWH
   EndIf
   If w > imW And h > imH
     Render.AutoSize = True
   Else
     Render.Width = w
     Render.Height = h
     Render.AutoSize = False
   EndIf
   Render.Move Render.Parent.ScaleWidth / 4 - Render.Width / 2, Render.Parent.ScaleHeight / 2 - Render.Height / 2
   
   PicCopy.Move Render.Left + 1, Render.Top + 1, Render.Width / 5, Render.Height / 5
   PicSave.Move PicCopy.Left + PicCopy.Width + 1, Render.Top + 1, Render.Width / 5, Render.Height / 5
   PicRandom.Move PicSave.Left + PicSave.Width + 1, Render.Top + 1, Render.Width / 5, Render.Height / 5
   
 EndIf
 
 x = GfaBGCreator.ScaleWidth / 2 + 10
 y = 10
 w = GfaBGCreator.ScaleWidth / 4 - 20
 For i = 1 To 14
   x = GfaBGCreator.ScaleWidth / 2 + 10 + Mod(Pred(i), 2) * (w + 20)
   y = 10 + Div(Pred(i), 2) * (TextHeight("L") + 40)
   If !IsNothing(Potar(i))
     Label(i).Move x, y, w, TextHeight("L")
     Potar(i).Move x, y + TextHeight("L") + 1, w, 32
     Potar(i).TickFrequency = Max(2, (Potar(i).Max - Potar(i).Min) / 10)
     
   EndIf
 Next i
 
EndSub
Sub Potar_MouseDown(Index%, Button&, Shift&, x!, y!)
 
EndSub
Sub Render_MouseMove(Button&, Shift&, x!, y!)
 PicCopy.Visible = True
 PicSave.Visible = True
 PicRandom.Visible = True
 
EndSub

Proc RenduProgressif(GO?)
 
 Static Long LineNDiv, Tiling, NT, NT2, i, T, NB, DecalRot, NAP, APM, Duplic, TotalComputing, CountComputing
 Static Double TilingPx, TilingPy, mx, my, r, pa, a, x1, y1, x2, y2, TXD, TYD, tAff
 Static Double tx1, ty1, tx2, ty2, a1, a2, r1, r2, aDuplic, Xmid, Ymid, TimeComputing, EstimatedTimeLeft
 Static Boolean RP_Start = True, RP_Stop = False, RP_Tiling = False, RP_Duplic = False
 Static Long D
 If GO? RP_Start = True : RP_Stop = False : RP_Tiling = False : RP_Duplic = False
 
 If Timer - tAff > 2
   Render.BackColor = 0
   tAff = Timer
 EndIf
 
 If RP_Stop = True
   If NAP > 0
     For APM = 1 To 1000
       If NAP > 0
         AffichageProgressif
         Dec NAP
       EndIf
     Next APM
   EndIf
   Exit Proc
 EndIf
 
 If RP_Start = True
   
   // Global render variables
   ReDim z(imW, imH)
   ArrayFill z(), 0
   Zmax = 0
   APA = imW
   Do
     Inc APA
   Loop Until IsPrime(APA) = True
   Afi = 0
   // Static
   
   Xmid = imW / 2
   Ymid = imH / 2
   NAP = imW * imH + 1
   tAff = Timer
   NB = CreatingPic.NB
   Duplic = CreatingPic.Duplication
   aDuplic = 2 * PI / Duplic
   pa = 2 * PI / Max(1, NB)
   LineNDiv = CreatingPic.LineNDiv
   Tiling = CreatingPic.Tiling
   TilingPx = imW / Max(1, Tiling)
   TilingPy = imH / Max(1, Tiling)
   NT = (1 + Tiling * 2)
   NT2 = NT * NT
   mx = imW * CreatingPic.Cx / 100
   my = imH * CreatingPic.Cy / 100
   r = (CreatingPic.Radius / 50) * Min(imW, imH) / 2
   DecalRot = CreatingPic.DecalRot
   i = 0
   TotalComputing = Duplic * NB * (1 + 2 * Tiling) ^ 2
   CountComputing = TotalComputing
   TimeComputing = Timer
   RP_Start = False
   
 EndIf
 
 If CountComputing > 1
   Dec CountComputing
   If Mod(CountComputing, 500) = 0
     EstimatedTimeLeft =  CountComputing * (Timer - TimeComputing) / (TotalComputing - CountComputing)
     GfaBGCreator.Caption = App.Name & " : Rendering... "  & Trim(CountComputing) & " lines left (" &  Trim(Round((1 - CountComputing / TotalComputing) * 100)) & "%) Estimated left time : "  & Round(EstimatedTimeLeft) & "s"
   EndIf
 Else
   GfaBGCreator.Caption = App.Name & " : Rendering is complete."
 EndIf
 
 If RP_Tiling = True
   
   TXD = (Mod(T, NT) - Tiling) * TilingPx
   TYD = (Div(T, NT) - Tiling) * TilingPy
   ZlineD x1 + TXD, y1 + TYD, x2 + TXD, y2 + TYD, LineNDiv
   Inc T
   If T = NT2
     RP_Tiling = False
     If i = NB And RP_Duplic = False RP_Stop = True
   EndIf
   
 Else
   
   If RP_Duplic = False
     
     a = i * pa : x1 = mx + Sin(a) * r : y1 = my + Cos(a) * r
     a = ((i + 1) * DecalRot) * pa : x2 = mx + Sin(a) * r : y2 = my + Cos(a) * r
     Inc i
     If Duplic > 1
       D = 0
       a1 = GetAngle(Xmid, Ymid, x1, y1)
       a2 = GetAngle(Xmid, Ymid, x2, y2)
       r1 = Sqr((Xmid - x1) ^ 2 + (Ymid - y1) ^ 2)
       r2 = Sqr((Xmid - x2) ^ 2 + (Ymid - y2) ^ 2)
       RP_Duplic = True
     EndIf
   EndIf
   
   If RP_Duplic = True
     x1 = Xmid + Sin(a1 + D * aDuplic) * r1
     y1 = Ymid + Cos(a1 + D * aDuplic) * r1
     x2 = Xmid + Sin(a2 + D * aDuplic) * r2
     y2 = Ymid + Cos(a2 + D * aDuplic) * r2
     Inc D
     If D = Duplic
       RP_Duplic = False
     EndIf
   EndIf
   
   If Tiling > 0
     T = 0
     RP_Tiling = True
   Else
     ZlineD x1, y1, x2, y2, LineNDiv
     If i = NB And RP_Duplic = False RP_Stop = True
   EndIf
   
 EndIf
 
 
EndProc
Proc ZlineD(x1#, y1#, x2#, y2#, D%)
 
 Local Double px, py
 Local Long i
 
 If D <= 1
   
   Zline x1, y1, x2, y2
   
 Else
   
   px = (x2 - x1) / (2 * D - 1)
   py = (y2 - y1) / (2 * D - 1)
   
   For i = 0 To Pred(D) * 2
     If Mod(i, 2) = 0 Zline x1, y1, x1 + px , y1 + py
     x1 = x1 + px
     y1 = y1 + py
   Next i
   
 EndIf
 
EndProc
Proc Zline(x1#, y1#, x2#, y2#)
 
 Local Long  X, Y, XX1, YY1, XX2, YY2, imSize
 Local Double h, ix, iy, u
 Static Double e = 3
 e = CreatingPic.Linethickness
 
 imSize = Min(imW, imH)
 XX1 = Int(x1)
 XX2 = Int(x2)
 If XX1 > XX2 Swap XX1, XX2
 YY1 = Int(y1)
 YY2 = Int(y2)
 If YY1 > YY2 Swap YY1, YY2
 
 Sub XX1, Int(e) + 2
 Add XX2, Int(e) + 2
 Sub YY1, Int(e) + 2
 Add YY2, Int(e) + 2
 
 XX1 = Max(0, Min(Pred(imW), XX1))
 XX2 = Max(0, Min(Pred(imW), XX2))
 YY1 = Max(0, Min(Pred(imH), YY1))
 YY2 = Max(0, Min(Pred(imH), YY2))
 
 For Y = YY1 To YY2
   For X = XX1 To XX2
     h = DistancePointSegment(X, Y, x1, y1, x2, y2, ix, iy, u)
     If h <= e And u >= 0 And u <= 1
       h = e - h
       z(X, Y) = z(X, Y) + h / e
       'z(X, Y) += Rnd
       If z(X, Y) > Zmax
         Zmax = z(X, Y)
       EndIf
     Else
       h = Sqr((X - x1) ^ 2 + (Y - y1) ^ 2)
       h = Min(h, Sqr((X - x2) ^ 2 + (Y - y2) ^ 2))
       If h <= e
         h = e - h
         z(X, Y) = z(X, Y) + h / e
         'z(X, Y) += Rnd
         If z(X, Y) > Zmax
           Zmax = z(X, Y)
         EndIf
       EndIf
       
     EndIf
   Next X
   AffichageProgressif
 Next Y
 
EndProc
Proc AffichageProgressif
 Static Large Afx, Afy
 
 Local Double C, r, g, b, zz
 
 'If AfpStop > 0
 ' Dec AfpStop
 Afi = Mod(Afi + APA, imW * imH)
 
 Afx = Mod(Afi, imW)
 Afy = Div(Afi, imW)
 Try
   If Zmax > 0
     zz = PI * z(Afx, Afy) / Zmax
   Else
     zz = 0
   EndIf
   r =  127.5 - Cos(CreatingPic.rfreq * zz) * 127.49
   g =  127.5 - Cos(CreatingPic.gfreq * zz) * 127.49
   b =  127.5 - Cos(CreatingPic.bfreq * zz) * 127.49
 Catch
   Message Err$ & #13#10 & Afi & " " & Afx & " " & Afy
 EndCatch
 imColor r, g, b
 imPlot Afx, Afy
 'EndIf
 '  PeekEvent : If Me Is Nothing End
 
EndProc
Proc ZADD(x#, y#, r#)
 Local Long XX, YY, ix, iy, rr
 Local Double h
 Static Long AP = 0
 'r = Abs(x - ImSize / 2) / (ImSize / 2)
 ' r = r * Abs(y - ImSize / 2) / (ImSize / 2)
 ' r = 0.5 + (2 - r) / 2
 r = 5
 rr = Int(r) + 1
 XX = Int(x)
 YY = Int(y)
 For iy = YY - rr To YY + rr
   If iy >= 0 And iy <= Pred(imH)
     For ix = XX - rr To XX + rr
       If ix >= 0 And ix <= Pred(imW)
         h = Sqr((ix - x) ^ 2 + (iy - y) ^ 2)
         If h <= r
           h = (r - h) / r
           z(ix, iy) = z(ix, iy) + h
           If z(ix, iy) > Zmax
             Zmax = z(ix, iy)
           EndIf
         EndIf
       EndIf
     Next ix
   EndIf
 Next iy
 Inc AP
 If AP = 20
   AP = 0
   AffichageProgressif
 EndIf
EndProc
Proc DuplicationLine(x1#, y1#, x2#, y2#, Nduplication%, cx#, cy#)
 
 Local Double a1, a2, r1, r2, aa, rz = 0
 Local Long i, Tiling, LineNDiv
 Local Long XD, YD
 
 LineNDiv = CreatingPic.LineNDiv
 a1 = GetAngle(cx, cy, x1, y1)
 a2 = GetAngle(cx, cy, x2, y2)
 r1 = Sqr((x1 - cx) ^ 2 + (y1 - cy) ^ 2)
 r2 = Sqr((x2 - cx) ^ 2 + (y2 - cy) ^ 2)
 Tiling = CreatingPic.Tiling
 For i = 0 To (Nduplication * 4) - 1
   
   If Mod(i, 4) = 0
     aa = i * (PI / 2) / Nduplication
   Else If Mod(i, 4) = 1
     aa = -aa
   Else If Mod(i, 4) = 2
     aa = PI - aa
   Else
     aa = -aa
   EndIf
   'aa = aa + PI / 5
   If Nduplication > 1
     x1 = cx + Sin(a1 + aa) * r1
     y1 = cy + Cos(a1 + aa) * r1
     x2 = cx + Sin(a2 + aa) * r2
     y2 = cy + Cos(a2 + aa) * r2
   EndIf
   
   If Tiling = 0
     ZlineD x1 , y1 , x2 , y2 , LineNDiv
   Else
     For YD = -imH To imH Step imH \ Tiling
       For XD = -imW To imW Step imW \ Tiling
         ZlineD x1 + XD, y1 + YD, x2 + XD, y2 + YD, LineNDiv
         AffichageProgressif
       Next XD
     Next YD
   EndIf
   
   Exit If Nduplication <= 1
   
 Next i
 
EndProc
Proc NewRandomCreating
 With CreatingPic
   .Linethickness = 1 + Rnd * Rnd * 50
   .LineNDiv = 1 + Rand(Rand(Rand(20)))
   .NB = 3 + Rand(Rand(Rand(Rand(250))))
   .DecalRot = 2 + Rand(Rand(Rand(12)))
   .Duplication = 3 + Rand(Rand(Rand(150)))
   .rfreq = Rnd * Rnd * 16
   .gfreq = Rnd * Rnd * 16
   .bfreq = Rnd * Rnd * 16
   .Tiling = Rand(4)
   .Cx = 50 + Rnd * 2 * (Rnd - 0.5) * 49
   .Cy = 50 + Rnd * 2 * (Rnd - 0.5) * 49
   .Radius = 50 + Rnd * 2 * (Rnd - 0.5) * 49
   Do
     .rfreq = Rnd * Rnd * Rnd * 100
     .gfreq = Rnd * Rnd * Rnd * 100
     .bfreq = Rnd * Rnd * Rnd * 100
   Loop Until .rfreq + .gfreq + .bfreq > 0
   
 EndWith
 SetPotarsValues
EndProc
Proc GetPotarsValues
 
 CreatingPic.Linethickness =  Potar(1).Value
 CreatingPic.LineNDiv = Potar(2).Value
 CreatingPic.NB = Potar(3).Value
 CreatingPic.DecalRot = Potar(4).Value
 CreatingPic.Duplication = Potar(5).Value
 CreatingPic.Tiling = Potar(6).Value
 CreatingPic.Cx = Potar(7).Value
 CreatingPic.Cy = Potar(8).Value
 CreatingPic.rfreq = Potar(9).Value
 CreatingPic.gfreq = Potar(10).Value
 CreatingPic.bfreq = Potar(11).Value
 imW = Potar(12).Value
 imH = Potar(13).Value
 CreatingPic.Radius = Potar(14).Value
 
EndProc
Proc StartRender
 ReDim z(imW, imH)
 ArrayFill z(), 0
 Zmax = 0
 APA = imW
 Do
   Inc APA
 Loop Until IsPrime(APA) = True
 Afi = 0
 AfpStop = imW * imH + 1
EndProc
Sub PicSave_Click
 
 Local Dim Ext(4) As String
 Local FileName As String
 
 Ext(1) = "*.Bmp" : Ext(0) = "Bitmap Files"
 Ext(2) = "" : Ext(3) = ""
 Dim a$
 Global Const OFN_OVERWRITEPROMPT = 2
 Global Const OFN_PATHMUSTEXIST = 2048
 Dlg Save Me, OFN_PATHMUSTEXIST | OFN_OVERWRITEPROMPT, "", "", "Bmp", Ext(), FileName
 
 If Len(FileName) > 0
   SavePicture Render.Picture, FileName
 EndIf
 
EndSub
Sub PicRandom_Click
 If Message("New random values ?", "GfaGBCreator", MB_YESNO) = IDYES
   NewRandomCreating
   RenduProgressif True
 EndIf
EndSub
Sub PicCopy_Click
 If PictureToClipBoard(MyPic) = False
   Message "Bitmap Copy failed"
 EndIf
EndSub
Proc DefTypes
 Type TYPE_CreatingPic
   - Double Linethickness
   - Long LineNDiv
   - Long NB
   - Long DecalRot
   - Long Duplication
   - Double rfreq, gfreq, bfreq
   - Long Tiling
   - Long Cx, Cy
   - Long Radius
 EndType
 Type BITMAPINFOHEADER
   - DWord biSize
   - Long  biWidth
   - Long  biHeight
   - Word  biPlanes
   - Word  biBitCount
   - DWord biCompression
   - DWord biSizeImage
   - Long  biXPelsPerMeter
   - Long  biYPelsPerMeter
   - DWord biClrUsed
   - DWord biClrImportant
 EndType
EndProc
Proc DefPotars
 
 Local Long i, x, y
 
 PotarNAme(1) = "Lines Thickness : "
 PotarNAme(2) = "Lines divisions : "
 PotarNAme(3) = "Number of branches : "
 PotarNAme(4) = "Decalage rotation : "
 PotarNAme(5) = "Duplications : "
 PotarNAme(6) = "Tiling : "
 PotarNAme(7) = "X origine : "
 PotarNAme(8) = "Y origine : "
 PotarNAme(9) = "Red Freq : "
 PotarNAme(10) = "Green Freq : "
 PotarNAme(11) = "Blue Freq : "
 PotarNAme(12) = "Image Width"
 PotarNAme(13) = "Image Height"
 PotarNAme(14) = "Radius"
 
 x = GfaBGCreator.ScaleWidth / 2 + 10
 y = 10
 
 For i = 1 To 14
   
   Ocx Label Label(i)
   Ocx Slider Potar(i)
   
   Potar(i).Move x, y + 30, 64, 32
   Potar(i).Min = 1
   Potar(i).Max = 100
   Potar(i).ToolTipText = "Potar " & Trim(i)
   Potar(i).TickFrequency = 10
   Potar(i).BorderStyle = 0
   Potar(i).TickStyle = 1
   Label(i).Move x, y, GfaBGCreator.ScaleWidth / 2 - 20, 30
   Potar(i).Move x, y + 31, GfaBGCreator.ScaleWidth / 2 - 20, 32
   Potar(i).LargeChange = 2
   Potar(i).SmallChange = 1
   
   y = y + 70
   If y + 70 > GfaBGCreator.ScaleHeight
     x = x - 70
     y = 10
   EndIf
   
 Next i
 
 Potar(1).Min = 1 : Potar(1).Max = 100
 Potar(2).Min = 1 : Potar(2).Max = 100
 Potar(3).Min = 1  : Potar(3).Max = 10000
 Potar(4).Min = 0 : Potar(4).Max = 100
 Potar(5).Min = 1 : Potar(5).Max = 100
 Potar(6).Min = 0 : Potar(6).Max = 10
 Potar(7).Min = 0 : Potar(7).Max = 100
 Potar(8).Min = 0 : Potar(8).Max = 100
 Potar(9).Min = 0 : Potar(9).Max = 100
 Potar(10).Min = 0 : Potar(10).Max = 100
 Potar(11).Min = 0 : Potar(11).Max = 100
 Potar(12).Min = 16 : Potar(12).Max = 2048
 Potar(13).Min = 16 : Potar(13).Max = 2048
 Potar(14).Min = 1 : Potar(14).Max = 100
 
 SetPotarsValues
 
EndProc
Proc SetPotarsValues
 Local Long i
 
 Potar(1).Value = CreatingPic.Linethickness
 Potar(2).Value = CreatingPic.LineNDiv
 Potar(3).Value = CreatingPic.NB
 Potar(4).Value = CreatingPic.DecalRot
 Potar(5).Value = CreatingPic.Duplication
 Potar(6).Value = CreatingPic.Tiling
 Potar(7).Value = CreatingPic.Cx
 Potar(8).Value = CreatingPic.Cy
 Potar(9).Value = CreatingPic.rfreq
 Potar(10).Value = CreatingPic.gfreq
 Potar(11).Value = CreatingPic.bfreq
 Potar(12).Value = imW
 Potar(13).Value = imW
 Potar(14).Value = CreatingPic.Radius
 
 For i = 1 To 14
   Label(i).Text = PotarNAme(i) & Potar(i).Value
 Next i
 
EndProc
Proc DefaultCreatingPic
 With CreatingPic
   .Linethickness = 10
   .LineNDiv = 1
   .NB = 6
   .DecalRot = 0
   .Duplication = 3
   .rfreq = 1
   .gfreq = 2
   .bfreq = 3
   .Tiling = 0
   .Cx = 50
   .Cy = 50
   .Radius = 45
 EndWith
EndProc
Proc ResizeRender
 Static Long OldimW = 0, OldimH = 0
 Local Long w, h
 
 'If OldimW > 0 Or OldimH > 0
 'FreeBmp hbm
 'EndIf
 
 If OldimW <> imW Or OldimH <> imH
   
   BIH.biSize = SizeOf(BIH)
   BIH.biPlanes = 1
   BIH.biBitCount = 32
   BIH.biWidth = imW
   BIH.biHeight = imH
   imMemSize = imW * imH * 4
   hbm = CreateDIBSection(Null, *BIH, DIB_RGB_COLORS, *imAdr, Null, 0)
   Set MyPic = CreatePicture(hbm, 1)
   Set Render.Picture = MyPic
   RapWH = imW / imH
   
   w = Render.Parent.ScaleWidth / 2 - 20
   h = w / RapWH
   If h > Render.Parent.ScaleHeight - 20
     h = Render.Parent.ScaleHeight - 20
     w = h * RapWH
   EndIf
   If w > imW And h > imH
     Render.AutoSize = True
   Else
     Render.Width = w
     Render.Height = h
     Render.AutoSize = False
   EndIf
   Render.Move Render.Parent.ScaleWidth / 4 - Render.Width / 2, Render.Parent.ScaleHeight / 2 - Render.Height / 2
   
 EndIf
 
 OldimW = imW
 OldimH = imH
 
EndProc
Function IsPrime(N As Variant) As Boolean
 
 Local Large i, NINT
 
 Select VarType(N)
 Case basCurrency, basDouble, basCard, basLong, basLarge
   
   If N > _maxLarge Return False
   If N < (_minLarge + 1) Return False
   
   NINT = Abs(Int(N))
   
   If NINT = 2 Return True
   
   If Mod(NINT, 2) = 0 Return False
   
   For i = 3 To Sqr(NINT) Step 2
     If Mod(NINT, i) = 0 Return False
   Next i
   
   Return True
   
 Case Else
   
   Return False
   
 EndSelect
 
EndFunc
Function GetAngle(x1#, y1#, x2#, y2#) As Double
 Local Double lx, a, h
 lx = x2 - x1
 h = Sqr(lx ^ 2 + (y2 - y1) ^ 2)
 If h > 0
   lx = lx / h
   If y2 > y1
     a = Asin(lx)
   Else
     a = PI - Asin(lx)
   EndIf
 EndIf
 If a < 0
   a = a + 2 * PI
 EndIf
 Return a
EndFunc
Function DistancePointSegment(px#, py#, x1#, y1#, x2#, y2#, ByRef ix#, ByRef iy#, ByRef U#) As Double
 
 ' Distance point / droite
 Local Double  h
 
 h = Sqr((x2 - x1) ^ 2 + (y2 - y1) ^ 2)
 If h NEAR 0
   ix = (x1 + x2) / 2 : iy = (y1 + y2) / 2
   Return Sqr((ix - px) ^ 2 + (iy - py) ^ 2)
 EndIf
 U = (((px - x1) * (x2 - x1)) + ((py - y1) * (y2 - y1)))
 U = U / (h ^ 2)
 ix = x1 + U * (x2 - x1)
 iy = y1 + U * (y2 - y1)
 
 Return Sqr((ix - px) ^ 2 + (iy - py) ^ 2)
 
End Function
Function PictureToClipBoard(ByRef MyPic As Picture) As Boolean
 
 Local Long Hwnd = 0, w, h, Bitmap
 
 w = MyPic.Width  * Screen.TwipsPerHimet / Screen.TwipsPerPixelX
 h = MyPic.Height * Screen.TwipsPerHimet / Screen.TwipsPerPixelY
 If w = 0 Or h = 0 Return False
 Form Hidden PictureToClipBoardForm
 PictureToClipBoardForm.AutoRedraw = True
 PictureToClipBoardForm.Adjust w, h
 PictureToClipBoardForm.PaintPicture MyPic, 0, 0
 Get 0, 0, w - 1, h - 1, Bitmap
 PictureToClipBoardForm.Close
 If !IsNothing(Me.hWnd) Hwnd = Me.hWnd
 If OpenClipboard(Hwnd) = 0 Return False
 ~EmptyClipboard()
 ~SetClipboardData(CF_BITMAP, Bitmap)
 ~CloseClipboard()
 FreeBmp Bitmap
 
 Return True
 
EndFunc


Have a nice day!

[ventilo25]

Merci pour cette démo, un travail remarquable, c'est très beau !

[scalion]

De rien, je vais l'améliorer quand même parce-qu'il traine un peu la patte et ça manque encore de sliders je trouve

[Emil_halim]

what a very nice piece  of Cake like code.

[scalion]

In order to speed up the rendering of lines I will limit the test area to the rectangle encompassing the surface of the line (which is no longer a line of the shot).

I just wrote the little routine that will do that I put you here the demo if you want to take a look:


Type TYPE_QUAD
 -Double x1, y1, x2, y2, x3, y3, x4, y4
EndType
Global Int ThickNess = 10
Global Q As TYPE_QUAD
Global Double x1, y1, x2, y2
FullW 1 : AutoRedraw = 1 : Me.Caption = App.Name
Void SetForegroundWindow(Me.hWnd)
Me.BackColor = 0
Ocx Command Tinc = "Increase Thickness", 10, 10, 200, 30
Ocx Command Tdec = "Decrease Thickness", 10, 50, 200, 30
Do
 Sleep
Loop Until Me Is Nothing
Sub Tinc_Click
 Add ThickNess, 5
 ShowMustGoOn
EndSub
Sub Tdec_Click
 ThickNess = Max(1, ThickNess - 5)
 ShowMustGoOn
EndSub
Sub Win_1_MouseMove(Button&, Shift&, x!, y!)
 x1 = _X / 2 : y1 = _Y / 2 : x2 = x! : y2 = y!
 ShowMustGoOn
EndSub
Proc ShowMustGoOn
 Cls
 RGBColor RGB(255, 255, 255) : Line x1, y1, x2, y2
 QuadAroundLine x1, y1, x2, y2, ThickNess, Q
 AffQuad Q
EndProc
Proc QuadAroundLine(x1#, y1#, x2#, y2#, thickness#, ByRef Q As TYPE_QUAD)

 Local Double r, lx, ly, s, c, h

 r = thickness * 1.4142135623730950488016887242
 lx = x2 - x1 : ly = y2 - y1
 s = (ly + lx) : c = (ly - lx)
 h = Sqr(s * s + c * c)

 If h = 0
   Q.x1 = x1 - thickness : Q.y1 = y1 - thickness
   Q.x2 = x1 + thickness : Q.y2 = Q.y1
   Q.x3 = Q.x2 : Q.y3 = y1 + thickness
   Q.x4 = Q.x1 : Q.y4 = Q.y3
 EndIf

 s = r * s / h
 c = r * c / h

 Q.x1 = x1 + c : Q.y1 = y1 - s
 Q.x2 = x2 + s : Q.y2 = y2 + c
 Q.x3 = x2 - c : Q.y3 = y2 + s
 Q.x4 = x1 - s : Q.y4 = y1 - c

EndProc
Proc AffQuad(ByRef Q As TYPE_QUAD)
 RGBColor RGB(255, 255, 0)
 Draw Q.x1, Q.y1 To Q.x2, Q.y2 To Q.x3, Q.y3 To Q.x4, Q.y4 To Q.x1, Q.y1
 RGBColor RGB(255, 255, 255)
 Text Q.x1, Q.y1, "P1"
 Text Q.x2, Q.y2, "P2"
 Text Q.x3, Q.y3, "P3"
 Text Q.x4, Q.y4, "P4"
EndProc


[scalion]

Hi all,

Now the next version including the rectangle encompassing speedup.
3 New sliders ! Line Hardness, Second radius and Second rotation.
1 New button : Reset to default value named RAZ.
1 fixed bug : Buttons alway's on the good place.
Hope you enjoy it !

Download here : GfaWildGeometryV2.G32 (27.07 KB)

And for final user the setup installer : setupGfaWildGeometryV2.exe (679.72 KB)

Have a nice day, and maybe see you soon for a new version !

[ventilo25]

Bonjour Scalion,

en utilisant ton jeu on se rend compte qu'il fonctionne un peu comme un kaléidoscope numérique, fascinant et magique, bravo !

[scalion]

Bonjour,
Bah Merci pour les compliments !!! C'est vrai que c'est simple et amusant comme ce bon vieux kaleidoscope.
D'ailleurs tu viens de m donner une idée...
A la prochaine

[scalion]

Hi all,

Version 3 is in the place, 1 2 3 ! In the place to be.

Ok i think that's my last of the last version but Ventilo25 tell me oh that's like kaleidoscope and ? Bing : Why not that's a good idea man !

Now this new feature :(any maybe or not maybe the last of the last...)

2 new sliders : Lighting and Lighting direction
1 new button : Kaleidoscope (using OpenGl).
Some new bugs of course but they affraid to me and i don't found for this moment.

The source code for all GFABASIC CODER's :  GfaWildGeometryV3.G32 (39.86 KB)

The setup installer for friends : setupGfaWildGeometryV3.exe (680.79 KB)

Than'ks for all and have a very good day (dont forget the sun is alway's here).

[scalion]

Bonjour JMM,
D'abord merci pour vos encouragements tout de même. Si opengl vous intéresse jetez donc un oeil dans le code source la librairie shiny ca vaut le détour c'est du code propre comme j'aime. C'est là dedans que je suis allé pioché les déclarations de fonctions OpenGl, c'est bien pratique.
Sinon, sauriez vous me programmer un petit control du style potentiomètre bien sympa ? Avec un look style Volume de vieille radio par exemple...
Parce-que j'ai essayé plusieurs trucs et c'est plutot moche et pas pratique (je suis obligé de passer par un pseudo-ocx incompatible avec tous les problème que ça entraine sur les conflit d'évènements notemment), je galère un peu quoi.
Et est-ce que vous savez où je pourrais trouver le code source du GFABASIC32 et du GFAWIN23.OCX ? Je sais c'est la question de trop, mais si je l'avais sous la main ce code, je crois que ce serait le saint-graal...
Bonne soirée

[scalion]

Ha oui, pourquoi pas. Je vais creuser par là. Merci et bonne fin de week-end.

[ventilo25]

Bonsoir Scalion, la version 3 avec le kaléidoscope est superbe, la manipulation ultra rapide avec la souris et l'effet d'assombrissement en s'éloignant du centre sont très réussis. Encore bravo !

[dragonjim]

An excellent demo and some clever programming.

Thank you for posting.