+- QB64 Phoenix Edition (https://staging.qb64phoenix.com)
+-- Forum: QB64 Rising (https://staging.qb64phoenix.com/forumdisplay.php?fid=1)
+--- Forum: Prolific Programmers (https://staging.qb64phoenix.com/forumdisplay.php?fid=26)
+---- Forum: SMcNeill (https://staging.qb64phoenix.com/forumdisplay.php?fid=29)
+---- Thread: Hourglass (/showthread.php?tid=145)
Hourglass - SMcNeill - 04-23-2022
Everybody else makes clocks... I made an hourglass!
Code: (Select All)
Screen _NewImage(1024, 720, 32)
_ScreenMove _Middle
_Define A-Z As LONG
Dim Shared SandCounter
Dim FillColor As _Unsigned Long
ReDim Shared Sand(100000) As Coord
ReDim Shared RemoveSand(100000) As Coord
Dim Pause As _Float
Const Seconds = 10
f = _LoadFont("OLDENGL.ttf", 32)
_Font f
Type Coord
x As Integer
y As Integer
End Type
CenterX = 512: CenterY = 360
FillColor = &HFFFF0000
DrawHourGlass CenterX, CenterY, 200, 50, 3, 3, -1
FillWithSand CenterX, CenterY, FillColor
PCopy 0, 1
_DontBlend
Do
PCopy 1, 0
For i = 1 To SandCounter: Sand(i).x = CenterX: Sand(i).y = CenterY + 1: Next
If Pause = 0 Then Pause = SandCounter / Seconds
CountDown = Seconds
o$ = Str$(CountDown): _PrintString (512 - _PrintWidth(o$) \ 2, 570), o$ + " "
min = 1: max = 0
t# = Timer(0.001)
Do
If max < SandCounter Then
max = max + 1
PSet (RemoveSand(max).x, RemoveSand(max).y), 0
End If
For i = min To max
If Point(Sand(i).x, Sand(i).y + 1) = 0 Then 'fall down
PSet (Sand(i).x, Sand(i).y), 0
Sand(i).y = Sand(i).y + 1
ElseIf Point(Sand(i).x - 1, Sand(i).y + 1) = 0 Then 'fall down and left
PSet (Sand(i).x, Sand(i).y), 0
Sand(i).x = Sand(i).x - 1: Sand(i).y = Sand(i).y + 1
ElseIf Point(Sand(i).x + 1, Sand(i).y + 1) = 0 Then 'fall down and right
PSet (Sand(i).x, Sand(i).y), 0
Sand(i).x = Sand(i).x + 1: Sand(i).y = Sand(i).y + 1
Else 'sit and don't move any more
min = min + 1
End If
PSet (Sand(i).x, Sand(i).y), FillColor
Next
If Timer - t# >= 1 Then t# = Timer(0.001): CountDown = CountDown - 1: o$ = Str$(CountDown): _PrintString (512 - _PrintWidth(o$) \ 2, 570), o$ + " "
_Limit Pause 'to set the timing properly (IF possible. Slow computers may not run this unoptimized code at speed for an hourglass with a low flip time.)
_Display
If _KeyHit Then System
Loop Until max = SandCounter
Loop
Sub FillWithSand (x, y, kolor As _Unsigned Long)
If Point(x - 1, y) = 0 Then
PSet (x - 1, y), kolor
SandCounter = SandCounter + 1
If SandCounter > UBound(Sand) Then
ReDim _Preserve Sand(UBound(Sand) + 100000) As Coord
ReDim _Preserve RemoveSand(UBound(Sand) + 100000) As Coord
End If
RemoveSand(SandCounter).x = x - 1: RemoveSand(SandCounter).y = y
FillWithSand x - 1, y, kolor
End If
If Point(x, y - 1) = 0 Then
PSet (x, y - 1), kolor
SandCounter = SandCounter + 1
If SandCounter > UBound(Sand) Then
ReDim _Preserve Sand(UBound(Sand) + 100000) As Coord
ReDim _Preserve RemoveSand(UBound(Sand) + 100000) As Coord
End If
RemoveSand(SandCounter).x = x: RemoveSand(SandCounter).y = y - 1
FillWithSand x, y - 1, kolor
End If
If Point(x + 1, y) = 0 Then
PSet (x + 1, y), kolor
SandCounter = SandCounter + 1
If SandCounter > UBound(Sand) Then
ReDim _Preserve Sand(UBound(Sand) + 100000) As Coord
ReDim _Preserve RemoveSand(UBound(Sand) + 100000) As Coord
End If
RemoveSand(SandCounter).x = x + 1: RemoveSand(SandCounter).y = y
FillWithSand x + 1, y, kolor
End If
End Sub
Sub DrawHourGlass (x, y, high, wide, gap, thick, kolor As _Unsigned Long) 'x/y center
Line (x - gap, y)-Step(-wide, -high), kolor
Line -Step(2 * (wide + gap), -thick), kolor, BF
Line (x + gap, y)-Step(wide, -high), kolor
Line (x + gap, y)-Step(wide, high), kolor
Line (x - gap, y)-Step(-wide, high), kolor
Line -Step(2 * (wide + gap), thick), kolor, BF
For thickness = 1 To thick
For Yborder = 0 To y + high + thick
For Xborder = 0 To x
If Point(Xborder + 1, Yborder) Then PSet (Xborder, Yborder), kolor 'thicken left
Next
For Xborder = x + wide + 2 * gap + thickness To x + 1 Step -1
If Point(Xborder - 1, Yborder) Then PSet (Xborder, Yborder), kolor 'thicken right
Next
Next
Next
End Sub