Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
Percentage-Clock: Starfield-Simulation-Variante
| Uploader: |  Dusky_Joe |
| Datum/Zeit: | 28.02.2006 16:38:59 |
Option Explicit
Option Dynamic
Randomize Timer
#Include "vbcompat.bi"
Const pi = 4# * Atn(1#)
Declare Sub Init ()
Declare Sub Load ()
Declare Sub StarField ()
Declare Sub PrepCock ()
Declare Sub UpdAmatur ()
Declare Sub DrwAWatch (value As Single, watchID As Integer, method As Integer, l As Single = 1)
Declare Function iBox (Msg As String) As Integer
#Define d2r(x) ((x) * pi / 180)
#Define hp (Hour (Now) / 24)
#Define mp (Minute(Now) / 60)
#Define sp (Second(Now) / 60)
#Define tp ((Second(Now) / 86400) + (Minute(Now) / 1440) + (Hour(Now) / 24))
#Define hp2 ((Hour(Now) Mod 12) / 12)
#Define p2a(x) ((x - .25) * 2 * pi)
#Define Sgk(x, y) ( Int(x * (10 ^ y)) / (10 ^ y) )
Declare Sub Config
Type StarType
x As Integer
y As Integer
z As Integer
c As Integer
xm As Single
ym As Single
zm As Single
End Type
Type SetType
PerTime : 1 As Integer
EqvTime : 1 As Integer
SinHour : 1 As Integer
SinMin : 1 As Integer
SinSek : 1 As Integer
Msgs : 1 As Integer
MsgSpd As Single
polycol : 1 As Integer
tw(3) As Integer
sw(3) As Integer
StarCnt As Integer
StarSpd As Integer
ScrMode As Integer
End Type
Dim Shared As Integer xRes, yRes, tMid
Dim Shared As Single sF
Dim Shared As SetType Settings
Dim Shared As String msgs()
'Dim Shared Font() As FontType
Dim Shared As Integer Ptr Cocpit
Select Case Left(Ucase(Command), 2)
Case "/S"
Init
PrepCock
StarField
Case "/P"
? Command
Case "/C" 'config
Load
Config
Case Else
Load
Config
End Select
Sub Init
Load
Screen Settings.ScrMode, 32, 2, 1
Color &H00FF00, &H004400
Select Case Settings.ScrMode
Case 16
xRes = 512
yRes = 384
tMid = 32
Case 18
xRes = 640
yRes = 480
tMid = 40
Case 19
xRes = 800
yRes = 600
tMid = 50
Case 20
xRes = 1024
yRes = 768
tMid = 64
Case 21
xRes = 1280
yRes = 1024
tMid = 80
End Select
sF = xRes / 20
SetMouse 320, 240, 0
End Sub
Sub Load ()
Dim As Integer i, f
f = FreeFile
Open Exepath + "\cps.txt" For Input As #f
Do Until Eof(1)
i += 1
Redim Preserve msgs(1 To i)
Line Input #1, msgs(i)
Loop
Close #f
Open Exepath + "\cps.set" For Binary As #f
If Lof(f) = 0 Then GoSub Defaults
Get #f, 1, Settings
Close #f
Goto ESL
Defaults:
With Settings
.PerTime = 1
.EqvTime = 1
.SinHour = 1
.SinMin = 1
.SinSek = 1
.Msgs = 1
.MsgSpd = .1
.polycol = 1
.tw(0) = 0
.tw(1) = 1
.tw(2) = 2
.tw(3) = 4
.sw(0) = 2
.sw(1) = 0
.sw(2) = 4
.sw(3) = 4
.StarCnt = 400
.StarSpd = 10
.ScrMode = 19
End With
Put #f, 1, Settings
ESL:
End Sub
Sub PrepCock
Dim i As Integer
Cocpit = ImageCreate (xRes, yRes)
' For i = 0 To 7.5 * sF Step 1
' Line (0, i)-(xRes, i), Rgb(192 * i \ yRes, 384 * i \ yRes, 384 * i \ yRes)
' Next
For i = 0 To xRes \ 2 Step xRes \ 20 * sF
Line (i, 0)-(i, 7.5 * sF), Rgb(192 * i / xRes, 192 * i / xRes, 384 * i / xRes)
Next
For i = xRes \ 2 To xRes Step xRes \ 20 * sF
Line (i, 0)-(i, 7.5 * sF), Rgb(192 * (xRes - i) / xRes, 192 * (xRes - i) / xRes, 384 * (xRes - i) / xRes)
Next
For i = 0 To xRes \ 2 Step xRes \ 20 * sF
Line (i, yRes)-(i, 7.5 * sF), Rgb(255 * i / xRes, 255 * i / xRes, 255 * i / xRes)
Next
For i = xRes \ 2 To xRes Step xRes \ 20 * sF
Line (i, yRes)-(i, 7.5 * sF), Rgb(255 * (xRes - i) / xRes, 255 * (xRes - i) / xRes, 255 * (xRes - i) / xRes)
Next
Circle (10 * sF , 7.5 * sF), 10 * sF, &HBBBBBB, 0, pi, .65
Circle (10 * sF , 10 * sF), 10 * sF, &HBBBBBB, 0, pi, .25
Circle (10 * sF - 1, 10 * sF), 10 * sF, &HBBBBBB, 0, pi, .25
Paint (10 * sF, 5 * sF), &HFF00FF, &HBBBBBB
Line (12.5 * sF, 7.58 * sF)-(17.5 * sF, 3.2 * sF), &HBBBBBB
Line ( 7.5 * sF, 7.58 * sF)-( 2.5 * sF, 3.2 * sF), &HBBBBBB
Line (13 * sF, 7.62 * sF)-(18 * sF, 3.6 * sF), &HBBBBBB
Line ( 7 * sF, 7.62 * sF)-( 2 * sF, 3.6 * sF), &HBBBBBB
Paint (17.3 * sF, 3.6 * sF), &H000080, &HBBBBBB
Paint ( 2.3 * sF, 3.6 * sF), &H000080, &HBBBBBB
Circle ( 2.5 * sF, 12.5 * sF), 2 * sF, &H001100 : Paint ( 2.5 * sF, 12.5 * sF), &H004400, &H001100
Circle (17.5 * sF, 12.5 * sF), 2 * sF, &H001100 : Paint (17.5 * sF, 12.5 * sF), &H004400, &H001100
Circle ( 5 * sF, 9.5 * sF), 1.5 * sF, &H001100 : Paint ( 5 * sF, 9.5 * sF), &H004400, &H001100
Circle (15 * sF, 9.5 * sF), 1.5 * sF, &H001100 : Paint (15 * sF, 9.5 * sF), &H004400, &H001100
Line ( 7 * sF, 8.5 * sF)-(13 * sF, 8.5 * sF), &H004400
Line ( 5 * sF, 14.5 * sF)-(15 * sF, 14.5 * sF), &H004400
Line ( 7 * sF, 8.5 * sF)-( 5 * sF, 14.5 * sF), &H004400
Line (13 * sF, 8.5 * sF)-(15 * sF, 14.5 * sF), &H004400
Paint (10 * sF, 10 * sF), &H004100, &H004400
Get (0, 0)-(xRes - 1, yRes - 1), Cocpit
Cls
End Sub
Sub StarField ()
Dim As Integer i, s, mX, mY, quit
Dim As Single rad
Dim As StarType Stars(Settings.StarCnt)
ScreenSet 1, 0
For i = 0 To Settings.StarCnt
With Stars(i)
.x = 0 : .y = 0 : .z = (Rnd * xRes) - (xRes \ 2)
.c = Rnd * 4
If Settings.polycol Then
Select Case .c
Case 0
.c = &HFFFFFF
Case 1
.c = &H00FFFF
Case 2
.c = &HFFFFAA
Case 3
.c = &H00BBFF
End Select
Else
.c = &HFFFFFF
End If
rad = d2r(Rnd * 360)
.xm = Cos(rad) : .ym = Sin(rad)
.zm = (Rnd * .3) + .7
.xm *= .zm : .ym *= .zm
End With
Next
Do
For i = 0 To Settings.StarCnt
With Stars(i)
If .z > 0 Then
s = .z Shr 7
Circle (.x + 10 * sF, .y + 5 * sF), s, 0, , , , F
End If
.z += 2 Shl s
If .z > (xRes \ 2) Then
.z = 0
.x = 0
.y = 0
End If
.x = .z * .xm
.y = .z * .ym
If .z > 0 Then
s = .z Shr 7
Circle (.x + 10 * sF, .y + 5 * sF), s, .c, , , , F
End If
End With
Next
Put (0, 0), Cocpit, Trans
UpdAmatur
ScreenCopy
Sleep Settings.StarSpd
GetMouse mX, mY
If (mX <> 320) Or (mY <> 240) Then quit = -1
'If Len(Inkey) Then quit = -1
Loop Until quit
End Sub
Sub DrwAWatch (v As Single, id As Integer, m As Integer, l As Single = 1)
' methods
' 0 - simple line
' 1 - filled area
' 2 - running colour
' 3 - square-watch
' 4 - filled square
Dim As Integer x, y, r, tx, ty, c
Dim As Single a, p, w, tmp
Select Case id
Case 0
x = 2.5 * sF
y = 12.5 * sF
r = 2.0 * sF * l
Case 1
x = 17.5 * sF
y = 12.5 * sF
r = 2.0 * sF * l
Case 2
x = 5.0 * sF
y = 9.5 * sF
r = 1.5 * sF
Case 3
x = 15.0 * sF
y = 9.5 * sF
r = 1.5 * sF * l
End Select
a = p2a(v)
tx = Cos(a) * r + x
ty = Sin(a) * r + y
Select Case m
Case 0
Line (x, y)-(tx, ty), &H00FF00
Case 1
Line (x, y)-(x, y - r), &H001100
Line (x, y)-(tx, ty), &H001100
Paint (x + 1, y - r + 1), &H008800, &H001100
Case 2
For p = 0 To v Step .0001
w = p2a(p)
If p <= .5 Then
c = Rgb(2 * p * 255, 255, 0)
Else
c = Rgb(255, (1 - p) * 2 * 255, 0)
End If
Line (x, y)-(x + Cos(w) * r, y + Sin(w) * r), c
Next
Line (x, y)-(tx, ty), &H0000FF
Case 3
Line ( x, y)-(tx, y), &H00FF00
Line (tx, y)-(tx, ty), &H00FF00
Case 4
Line ( x, y)-(x, y - r), &H001100
Line ( x, y)-(tx, y ), &H001100
Line (tx, y)-(tx, ty ), &H001100
Paint (x + 1, y - 1), &H008800, &H001100
End Select
End Sub
Sub UpdAmatur ()
Dim As Integer i, r, l, c
Dim As String msg
Static As Single t
Static As Integer id, p, wfn
r = (8.6 * sF) / 16 + 2
l = (6 * sF) \ 128 ' 6*sF => Height; 128 = 8 needet Lines * 16 Pixels per Line
With Settings
' '12345678901234' => 14 columns
If .PerTime Then Locate r, tMid - 7 : ? Using "Time: ###.###%"; tp * 100
r += l
If .EqvTime Then Locate r, tMid - 7 : ? Using "eqv : &"; Time
r += 2 * l
' '1234567890123456789012' => 22 columns
If .SinHour Then Locate r, tMid - 11 : ? Using "hour : c#.###, s#.###"; Sgk(Cos(p2a(hp2)), 3); Sgk(Sin(p2a(hp2)), 3)
r += l
If .SinMin Then Locate r, tMid - 11 : ? Using "minute: c#.###, s#.###"; Sgk(Cos(p2a(mp )), 3); Sgk(Sin(p2a(mp )), 3)
r += l
If .SinSek Then Locate r, tMid - 11 : ? Using "second: c#.###, s#.###"; Sgk(Cos(p2a(sp )), 3); Sgk(Sin(p2a(sp )), 3)
r += 2 * l
If .Msgs Then
' space for msg: 30 columns
If t = 0 Then
t = Timer
p = 1
id = Rnd * (UBound(msgs) + 1)
If id > UBound(msgs) Then id = Ubound(msgs)
End If
msg = msgs(id) + Space(30)
If p > 30 Then
msg = Mid(msg, p - 30, 30)
c = 14
Else
msg = Mid(msg, 1, p)
c = p - 16
End If
Locate r, tMid - c : ? msg
If t + Settings.MsgSpd < Timer Then
p += 1
t = Timer
End If
If p = Len(msgs(id)) + 30 Then t = 0
End If
End With
For i = 0 To 3
' .tw():
' 0 whole Time
' 1 HMS
' 2 H
' 3 H12
' 4 M
' 5 S
Select Case Settings.tw(i)
Case 0
DrwAWatch tp, i, Settings.sw(i)
Case 1
DrwAWatch hp2, i, Settings.sw(i)
DrwAWatch mp , i, Settings.sw(i), .75
DrwAWatch sp , i, Settings.sw(i), .50
Case 2
DrwAWatch hp , i, Settings.sw(i)
Case 3
DrwAWatch hp2, i, Settings.sw(i)
Case 4
DrwAWatch mp , i, Settings.sw(i)
Case 5
DrwAWatch sp , i, Settings.sw(i)
End Select
Next
End Sub
Sub Config
Windowtitle "CPS: Settings"
Screen 15, 32, 2
ScreenSet 0, 1
Dim As Integer i, j, done, x, y, f
Dim As String ScrRes
Redo:
Cls
Locate 1, 1
Color &HFFFF00, &HFF0000
? " Percentage Clock "; ' 1
? " Starfield-Simulation-Variante " ' 2
Color &HFFFFFF, 0
? " [ ] Prozent-Zeit" ' 4
? " [ ] Aequivalent-Zeit" ' 5
?
? " [ ] S/C-Stundenanzeige" ' 7
? " [ ] S/C-Minutenanzeige" ' 8
? " [ ] S/C-Sekundenanzeige" ' 9
?
? " [ ] Textnachrichten" ' 11
If Settings.Msgs = 0 Then
Color &H888888
Locate 12, 15
? "Geschwindigkeit: ";
? Using "###"; (1 - Settings.MsgSpd) * 1000 ' 12
Else
Locate 12, 15
? "Geschwindigkeit: ";
Color &H00FFFF
? Using "###"; (1 - Settings.MsgSpd) * 1000
Color &HFFFFFF
End If
Color &HFFFFFF
?
? " [ ] mehrfarbige Sterne" ' 14
?
? " Uhr... Verwendung... Style" ' 16
? " ( ) 1 ( ) Pro ( ) Line" ' 17
? " ( ) 2 ( ) Eqv ( ) Area" ' 18
? " ( ) 3 ( ) Std ( ) Verlauf" ' 19
? " ( ) 4 ( ) 12h ( ) Squared" ' 20
? " ( ) Min ( ) Filled Square" ' 21
? " ( ) Sec" ' 22
?
? " Anzahl der Sterne : "; ' 24
Color &H00FFFF
? Using "###"; Settings.StarCnt
Color &HFFFFFF
? " Geschwindigkeit der Sterne: "; ' 25
Color &H00FFFF
? Using "###"; 1000 - Settings.StarSpd
Color &HFFFFFF
?
? " Aufloesung: "; : Color &H000000, &H00FFFF ' 27
Select Case Settings.ScrMode
Case 16
ScrRes = " 512x384"
Case 18
ScrRes = " 640x480"
Case 19
ScrRes = " 800x600"
Case 20
ScrRes = " 1024x768"
Case 21
ScrRes = "1280x1024"
End Select
? ScrRes + Chr(32, 25) : Color &HFFFFFF ' Chr(31) : Arrow down
Color &HFFFF00, &H0000FF
Locate 34, 3 : ? Chr(201) + String(19, 205) + Chr(187)
Locate 35, 3 : ? Chr(186) + " Speichern " + Chr(186)
Locate 36, 3 : ? Chr(200) + String(19, 205) + Chr(188)
Locate 34, 28 : ? Chr(201) + String(19, 205) + Chr(187)
Locate 35, 28 : ? Chr(186) + " Abbrechen " + Chr(186)
Locate 36, 28 : ? Chr(200) + String(19, 205) + Chr(188)
Color &HFFFFFF, 0
With Settings
If .PerTime Then Locate 4, 3 : Print "X"
If .EqvTime Then Locate 5, 3 : Print "X"
If .SinHour Then Locate 7, 3 : Print "X"
If .SinMin Then Locate 8, 3 : Print "X"
If .SinSek Then Locate 9, 3 : Print "X"
If .Msgs Then Locate 11, 3 : Print "X"
If .polycol Then Locate 14, 3 : Print "X"
Locate 17 + i , 4 : Print "*"
Locate 17 + .tw(i), 15 : Print "*"
Locate 17 + .sw(i), 32 : Print "*"
End With
ScreenCopy
ReMouse:
Do
Sleep 1
GetMouse x, y, , done
Loop Until done
If done <> 1 Then Goto ReMouse
x = Fix(x / 8) + 1
y = Fix(y / 8) + 1
With Settings
If x = 3 Then
Select Case y
Case 4
.PerTime = .PerTime Xor 1 : Sleep 150 : Goto ReDo
Case 5
.EqvTime = .EqvTime Xor 1 : Sleep 150 : Goto ReDo
Case 7
.SinHour = .SinHour Xor 1 : Sleep 150 : Goto ReDo
Case 8
.SinMin = .SinMin Xor 1 : Sleep 150 : Goto ReDo
Case 9
.SinSek = .SinSek Xor 1 : Sleep 150 : Goto ReDo
Case 11
.Msgs = .Msgs Xor 1 : Sleep 150 : Goto ReDo
Case 14
.polycol = .polycol Xor 1 : Sleep 150 : Goto ReDo
End Select
End If
If x = 4 Then
If y >= 17 And y <= 20 Then i = y - 17
Goto ReDo
End If
If x = 15 Then
If y >= 17 And y <= 22 Then .tw(i) = y - 17
Goto ReDo
End If
If x = 32 Then
If y >= 17 And y <= 21 Then .sw(i) = y - 17
Goto ReDo
End If
If x >= 15 And x <= 34 And y = 12 Then
.MsgSpd = IBox("Neue Textgeschwindigkeit (1 - 999)?")
.MsgSpd = 1000 - (.MsgSpd Mod 1000)
If .MsgSpd = 0 Then .MsgSpd = 1
.MsgSpd /= 1000
Goto ReDo
End If
If x >= 1 And x <= 32 Then
If y = 24 Then
.StarCnt = IBox("Anzahl der Sterne (1 - 999)?")
.StarCnt = .StarCnt Mod 1000
If .StarCnt = 0 Then .StarCnt = 1
Goto ReDo
ElseIf y = 25 Then
.StarSpd = IBox("Neue Sterngeschwindigkeit (0-999)?")
.StarSpd = 1000 - (.StarSpd Mod 1000)
Goto ReDo
End If
End If
If y = 27 Then
If x >= 2 And x <= 24 Then
Color &H000000, &H00BBBB
Locate 28, 14 : ? " 512x384 "
Locate 29, 14 : ? " 640x480 "
Locate 30, 14 : ? " 800x600 "
Locate 31, 14 : ? " 1024x768 "
Locate 32, 14 : ? "1280x1024 "
Color &HFFFFFF, &H000000
ScreenCopy
Sleep 100
Do
Sleep 1
GetMouse x, y, , done
Loop Until done
If done <> 1 Then Goto ReDo
x = Fix(x / 8) + 1
y = Fix(y / 8) + 1
If x >= 14 And x <= 24 Then
Select Case y
Case 28
.ScrMode = 16
Case 29
.ScrMode = 18
Case 30
.ScrMode = 19
Case 31
.ScrMode = 20
Case 32
.ScrMode = 21
End Select
End If
Goto ReDo
End If
End If
End With
If (y >= 34) And (y <= 36) Then
If (x >= 3) And (x <= 23) Then ' Speichern
f = FreeFile
Open Exepath + "\cps.set" For Binary As #f
Put #f, 1, Settings
Close #f
End
End If
If (x >= 28) And (x <= 47) Then ' Abbrechen
End
End If
End If
Goto ReMouse
End Sub
Function IBox(Msg As String) As Integer
Dim As Integer LoM
Dim As String Re, k
Msg = Chr(32) + Msg + Chr(32)
LoM = Len(Msg)
Color &H00FFFF, &H0000FF
Locate 16, (50 - LoM - 2) \ 2 : ? Chr(201) + String(LoM, 205) + Chr(187)
Locate 17, (50 - LoM - 2) \ 2 : ? Chr(186) + Msg + Chr(186)
Locate 18, (50 - LoM - 2) \ 2 : ? Chr(186) + Space (LoM) + Chr(186)
Locate 19, (50 - LoM - 2) \ 2 : ? Chr(186) + Space (LoM) + Chr(186)
Locate 20, (50 - LoM - 2) \ 2 : ? Chr(200) + String(LoM, 205) + Chr(188)
Do
ScreenCopy
Sleep 1
k = Inkey
Select Case k
Case Chr(8)
If Len(Re) Then Re = Left(Re, Len(Re) - 1)
Case Chr(13)
Exit Do
Case Else
Re += k
If Len(Re) > LoM - 2 Then Re = Left(Re, LoM - 2)
End Select
Locate 19, (50 - LoM - 2) \ 2 + 2
? Re + Space(LoM - Len(Re) - 1)
Loop
Color &HFFFFFF, &H000000
Function = Val(Re)
End Function