10-17-2024, 09:20 PM
As you guys can probably tell, bplus had me digging around in old drives and such looking for 2048 (Double Up) related code, and I've ran into a lot of old junk which I thought I'd share that someone might like. Here's an old gear-clock that used to connect to the internet and get the weather and temperature and such for Steve's Place, back in the day. Unfortunately the website I used to connect to to get that info no longer exists, so it can't tell you that anymore. Now, it's just a funny looking clock, missing out on the important bits that I liked the most with it. 
Maybe I'll hunt down another site with a RSS feed for local weather according to lat/long. There's bound to be one out there on the web somewhere!
Code: (Select All)
Screen _NewImage(640, 480, 32)
_ScreenMove _Middle
Dim Shared hourgear, minutegear, secondgear, center
Print "Initializing clock..."
hourgear = DrawHourGear(&HFFFF00FF)
minutegear = DrawMinuteGear(&HFFFFFF00)
secondgear = DrawSecondGear(&HFF00FF00)
center = CenterDisplay
Do
_Limit 60
Cls , 0
AssembleClock 80, 0, 560, _Height
ManualAdjustment
_Display
Loop
Sub ManualAdjustment
Shared Adjustment As _Float
A = 1
If _KeyDown(100306) Or _KeyDown(100305) Then A = 60
If _KeyDown(100304) Or _KeyDown(100303) Then A = 3600
k = _KeyHit
Select Case k
Case 32 'space
Adjustment = 0
Case 19200, 20480 'left / down
Adjustment = Adjustment - A
Case 18332, 19712 'up / right
Adjustment = Adjustment + A
Case 27 'escape to quite
System
End Select
End Sub
Sub AssembleClock (x1, y1, x2, y2)
Shared Adjustment As _Float
d = _Dest
tempimage = _NewImage(480, 480, 32)
_Dest tempimage
W = _Width \ 2: h = _Height \ 2
If W > h Then R = h Else R = W
t## = Adjustment + Timer
hour = t## \ 3600
minute = (t## - hour * 3600) \ 60
second = t## - hour * 3600 - minute * 60
DisplayImage hourgear, 240, 240, hour * 30, 0
DisplayImage minutegear, 240, 240, minute * 6, 0
DisplayImage secondgear, 240, 240, second * 6, 0
DisplayImage center, 240, 240, 0, 0
_Dest d
_PutImage (x1, y1)-(x2, y2), tempimage, d, (0, 0)-(479, 479)
_FreeImage tempimage
_Dest d
End Sub
Function CenterDisplay
Static oldmm
d = _Dest
OldFont = _Font
CenterDisplaytemp = _NewImage(175, 100, 32)
_Dest CenterDisplaytemp
F = _LoadFont("courbd.ttf", 24)
F1 = _LoadFont("courbd.ttf", 30)
If F > 0 Then _Font F Else _Font 16
Cls
d$ = Date$
Select Case Left$(d$, 2)
Case "01": month$ = "JAN"
Case "02": month$ = "FEB"
Case "03": month$ = "MAR"
Case "04": month$ = "APR"
Case "05": month$ = "MAY"
Case "06": month$ = "JUN"
Case "07": month$ = "JUL"
Case "08": month$ = "AUG"
Case "09": month$ = "SEP"
Case "10": month$ = "OCT"
Case "11": month$ = "NOV"
Case "12": month$ = "DEC"
End Select
mm = Val(Left$(d$, 2))
dd = Val(Mid$(d$, 4))
yy = Val(Right$(d$, 4))
Print month$; " "; Mid$(d$, 4, 2); ", "; Right$(d$, 4);
day$ = GetDay$(mm, dd, yy)
If F1 > 0 Then SafeLoadFont F1 Else SafeLoadFont 16
day$ = "Wednesday"
s$ = Space$((10 - Len(day$)) \ 2)
Print s$ + day$;
_Font 16
If F > 0 Then _FreeFont F
If F1 > 0 Then _FreeFont F1
If oldmm <> mm Then 'try to update the weather every minute
rss$ = DownloadRSS("http://rss.wunderground.com/q/zmw:24138.1.99999", 5)
'<meta property="og:title" content="Pilot, VA | 37.2° | Overcast" />
t$ = "<meta property=" + Chr$(34) + "og:title" + Chr$(34) + " content=" + Chr$(34)
l = InStr(rss$, t$)
endl = InStr(l, rss$, "/>")
temp$ = Mid$(rss$, l + Len(t$), endl - l)
_Font 8
fs = InStr(temp$, "|")
ss = InStr(fs + 1, temp$, "|")
el = InStr(ss + 1, temp$, Chr$(34))
city$ = Left$(temp$, fs - 1)
temp = Val(Mid$(temp$, fs + 1))
condition$ = Mid$(temp$, ss + 1, el - ss - 1)
Locate 9, 1
Print city$; temp; condition$;
oldmm = mm
End If
_Font 16
_Dest d
CenterDisplay = CenterDisplaytemp
End Function
Function DrawHourGear (Kolor As _Unsigned Long)
D = _Dest
DrawHourGeartemp = _NewImage(640, 480, 32)
_Dest DrawHourGeartemp
OldFont = _Font
W = _Width \ 2: h = _Height \ 2
F = _LoadFont("OLDENGL.TTF", 48)
If F > 0 Then _Font F Else _Font 16
If W > h Then R = h - 1 Else R = W - 1
FH = _FontHeight \ 2
CircleFill W, h, R, Kolor
Color &HFF000000, 0
For i = 1 To 12
X = W + R * .9 * Cos(_D2R(i * 30 - 90))
Y = h + R * .9 * Sin(_D2R(i * 30 - 90))
t$ = _Trim$(Str$(i))
tempimage = TextToImage&(t$, F, &HFF000000, 0, 0)
DisplayImage tempimage, X, Y, -i * 30, 0
_FreeImage tempimage
Next
_Font OldFont
If F > 0 Then _FreeFont F
'CircleFill W, H, 10, &HFF000000
_Dest D
DrawHourGear = DrawHourGeartemp
End Function
Function DrawMinuteGear (Kolor As _Unsigned Long)
D = _Dest
DrawMinuteGeartemp = _NewImage(640, 480, 32)
_Dest DrawMinuteGeartemp
OldFont = _Font
W = _Width \ 2: h = _Height \ 2
F = _LoadFont("OLDENGL.TTF", 18)
If F > 0 Then _Font F Else _Font 16
If W > h Then R = h * .8 Else R = W * .8
FH = _FontHeight \ 2
CircleFill W, h, R, Kolor
Color &HFF000000, 0
For i = 0 To 59
X = W + R * .9 * Cos(_D2R(i * 6 - 90))
Y = h + R * .9 * Sin(_D2R(i * 6 - 90))
t$ = _Trim$(Str$(i \ 10))
tempimage = TextToImage&(t$, F, &HFF000000, 0, 0)
DisplayImage tempimage, X, Y, -i * 6, 0
_FreeImage tempimage
X = W + R * .8 * Cos(_D2R(i * 6 - 90))
Y = h + R * .8 * Sin(_D2R(i * 6 - 90))
t$ = _Trim$(Str$(i Mod 10))
tempimage = TextToImage&(t$, F, &HFF000000, 0, 0)
DisplayImage tempimage, X, Y, -i * 6, 0
_FreeImage tempimage
Next
_Font OldFont
If F > 0 Then _FreeFont F
'CircleFill W, H, 10, &HFF000000
_Dest D
DrawMinuteGear = DrawMinuteGeartemp
End Function
Function DrawSecondGear (Kolor As _Unsigned Long)
D = _Dest
DrawSecondGeartemp = _NewImage(640, 480, 32)
_Dest DrawSecondGeartemp
OldFont = _Font
W = _Width \ 2: h = _Height \ 2
F = _LoadFont("OLDENGL.TTF", 18)
If F > 0 Then _Font F Else _Font 16
If W > h Then R = h * .6 Else R = W * .6
FH = _FontHeight \ 2
CircleFill W, h, R, Kolor
Color &HFF000000, 0
For i = 0 To 59
X = W + R * .9 * Cos(_D2R(i * 6 - 90))
Y = h + R * .9 * Sin(_D2R(i * 6 - 90))
t$ = _Trim$(Str$(i \ 10))
tempimage = TextToImage&(t$, F, &HFF000000, 0, 0)
DisplayImage tempimage, X, Y, -i * 6, 0
_FreeImage tempimage
X = W + R * .8 * Cos(_D2R(i * 6 - 90))
Y = h + R * .8 * Sin(_D2R(i * 6 - 90))
t$ = _Trim$(Str$(i Mod 10))
tempimage = TextToImage&(t$, F, &HFF000000, 0, 0)
DisplayImage tempimage, X, Y, -i * 6, 0
_FreeImage tempimage
Next
_Font OldFont
'CircleFill W, H, 10, &HFF000000
_Dest D
DrawSecondGear = DrawSecondGeartemp
End Function
Sub CircleFill (CX As Integer, CY As Integer, R As Integer, C As _Unsigned Long)
' CX = center x coordinate
' CY = center y coordinate
' R = radius
' C = fill color
Dim Radius As Integer, RadiusError As Integer
Dim X As Integer, Y As Integer
Radius = Abs(R)
RadiusError = -Radius
X = Radius
Y = 0
If Radius = 0 Then PSet (CX, CY), C: Exit Sub
Line (CX - X, CY)-(CX + X, CY), C, BF
While X > Y
RadiusError = RadiusError + Y * 2 + 1
If RadiusError >= 0 Then
If X <> Y + 1 Then
Line (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
End If
X = X - 1
RadiusError = RadiusError - X * 2
End If
Y = Y + 1
Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
Wend
End Sub
Sub DisplayImage (Image As Long, x As Integer, y As Integer, angle As Single, mode As _Byte)
'Image is the image handle which we use to reference our image.
'x,y is the X/Y coordinates where we want the image to be at on the screen.
'angle is the angle which we wish to rotate the image.
'mode determines HOW we place the image at point X,Y.
'Mode 0 we center the image at point X,Y
'Mode 1 we place the Top Left corner of oour image at point X,Y
'Mode 2 is Bottom Left
'Mode 3 is Top Right
'Mode 4 is Bottom Right
Dim px(3) As Integer, py(3) As Integer, w As Integer, h As Integer
Dim sinr As Single, cosr As Single, i As _Byte
w = _Width(Image): h = _Height(Image)
Select Case mode
Case 0 'center
px(0) = -w \ 2: py(0) = -h \ 2: px(3) = w \ 2: py(3) = -h \ 2
px(1) = -w \ 2: py(1) = h \ 2: px(2) = w \ 2: py(2) = h \ 2
Case 1 'top left
px(0) = 0: py(0) = 0: px(3) = w: py(3) = 0
px(1) = 0: py(1) = h: px(2) = w: py(2) = h
Case 2 'bottom left
px(0) = 0: py(0) = -h: px(3) = w: py(3) = -h
px(1) = 0: py(1) = 0: px(2) = w: py(2) = 0
Case 3 'top right
px(0) = -w: py(0) = 0: px(3) = 0: py(3) = 0
px(1) = -w: py(1) = h: px(2) = 0: py(2) = h
Case 4 'bottom right
px(0) = -w: py(0) = -h: px(3) = 0: py(3) = -h
px(1) = -w: py(1) = 0: px(2) = 0: py(2) = 0
End Select
sinr = Sin(angle / 57.2957795131): cosr = Cos(angle / 57.2957795131)
For i = 0 To 3
x2 = (px(i) * cosr + sinr * py(i)) + x: y2 = (py(i) * cosr - px(i) * sinr) + y
px(i) = x2: py(i) = y2
Next
_MapTriangle (0, 0)-(0, h - 1)-(w - 1, h - 1), Image To(px(0), py(0))-(px(1), py(1))-(px(2), py(2))
_MapTriangle (0, 0)-(w - 1, 0)-(w - 1, h - 1), Image To(px(0), py(0))-(px(3), py(3))-(px(2), py(2))
End Sub
Function TextToImage& (text$, font&, fc&, bfc&, mode As _Byte)
'text$ is the text that we wish to transform into an image.
'font& is the handle of the font we want to use.
'fc& is the color of the font we want to use.
'bfc& is the background color of the font.
'Mode 1 is print forwards
'Mode 2 is print backwards
'Mode 3 is print from top to bottom
'Mode 4 is print from bottom up
'Mode 0 got lost somewhere, but it's OK. We check to see if our mode is < 1 or > 4 and compensate automatically if it is to make it one (default).
If mode < 1 Or mode > 4 Then mode = 1
dc& = _DefaultColor: bgc& = _BackgroundColor
D = _Dest
F = _Font
If font& <> 0 Then _Font font&
If mode < 3 Then
'print the text lengthwise
w& = _PrintWidth(text$): h& = _FontHeight
Else
'print the text vertically
For i = 1 To Len(text$)
If w& < _PrintWidth(Mid$(text$, i, 1)) Then w& = _PrintWidth(Mid$(text$, i, 1))
Next
h& = _FontHeight * (Len(text$))
End If
tempTextToImage& = _NewImage(w&, h&, 32)
_Dest tempTextToImage&
If font& <> 0 Then _Font font&
Color fc&, bfc&
Select Case mode
Case 1
'Print text forward
_PrintString (0, 0), text$
Case 2
'Print text backwards
temp$ = ""
For i = 0 To Len(text$) - 1
temp$ = temp$ + Mid$(text$, Len(text$) - i, 1)
Next
_PrintString (0, 0), temp$
Case 3
'Print text upwards
'first lets reverse the text, so it's easy to place
temp$ = ""
For i = 0 To Len(text$) - 1
temp$ = temp$ + Mid$(text$, Len(text$) - i, 1)
Next
'then put it where it belongs
For i = 1 To Len(text$)
fx = (w& - _PrintWidth(Mid$(temp$, i, 1))) / 2 + .99 'This is to center any non-monospaced letters so they look better
_PrintString (fx, _FontHeight * (i - 1)), Mid$(temp$, i, 1)
Next
Case 4
'Print text downwards
For i = 1 To Len(text$)
fx = (w& - _PrintWidth(Mid$(text$, i, 1))) / 2 + .99 'This is to center any non-monospaced letters so they look better
_PrintString (fx, _FontHeight * (i - 1)), Mid$(text$, i, 1)
Next
End Select
_Dest D
Color dc&, bgc&
_Font F
TextToImage& = tempTextToImage&
End Function
Function GetDay$ (mm, dd, yyyy) 'use 4 digit year
'From Zeller's congruence: https://en.wikipedia.org/wiki/Zeller%27s_congruence
If mm < 3 Then mm = mm + 12: yyyy = yyyy - 1
century = yyyy Mod 100
zerocentury = yyyy \ 100
result = (dd + Int(13 * (mm + 1) / 5) + century + Int(century / 4) + Int(zerocentury / 4) + 5 * zerocentury) Mod 7
Select Case result
Case 0: GetDay$ = "Saturday"
Case 1: GetDay$ = "Sunday"
Case 2: GetDay$ = "Monday"
Case 3: GetDay$ = "Tuesday"
Case 4: GetDay$ = "Wednesday"
Case 5: GetDay$ = "Thursday"
Case 6: GetDay$ = "Friday"
End Select
End Function
Sub SafeLoadFont (font#)
'Safely loads a font without destroying our current print location and making it revert to the top left corner.
down = CsrLin: right = Pos(0)
down = (down - 1) * _FontHeight
If _FontWidth <> 0 Then 'weed start with a monospace font
right = (right - 1) * _PrintWidth(" ") 'convert the monospace LOC to a graphic X coordinate
End If
_Font font#
If _FontWidth <> 0 Then 'we swapped to a monospace font
right = (right / _PrintWidth(" ")) + 1 'convert the graphic X coordinate back to a monospace LOC column
End If
down = (down / _FontHeight) + 1
If right < 1 Then right = 1
Locate down, right
End Sub
Function DownloadRSS$ (url$, timelimit)
link$ = url$
url2$ = RTrim$(LTrim$(link$))
url4$ = RTrim$(LTrim$(link$))
If Left$(UCase$(url2$), 7) = "HTTP://" Then url4$ = Mid$(url2$, 8)
x = InStr(url4$, "/")
If x Then url2$ = Left$(url4$, x - 1)
NewsClient = _OpenClient("TCP/IP:80:" + url2$)
If NewsClient = 0 Then Exit Function
e$ = Chr$(13) + Chr$(10) ' end of line characters
url3$ = Right$(url4$, Len(url4$) - x + 1)
x$ = "GET " + url3$ + " HTTP/1.1" + e$
x$ = x$ + "Host: " + url2$ + e$ + e$
Put #NewsClient, , x$
t! = Timer ' start time
head$ = ""
cont_type$ = ""
Do
_Limit 20
Get #NewsClient, , a$
If LTrim$(a$) > "" Then final$ = final$ + a$
If InStr(a$, "</html>") Then Exit Do 'we hit the end of the file
Loop Until Timer > t! + timelimit And timelimit > 0 ' (in seconds)
DownloadRSS$ = final$
End Function
Maybe I'll hunt down another site with a RSS feed for local weather according to lat/long. There's bound to be one out there on the web somewhere!