Hourglass

[SMcNeill]

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