mirror of
https://github.com/QB64Official/qb64.git
synced 2024-07-08 07:55:14 +00:00
325 lines
7 KiB
QBasic
325 lines
7 KiB
QBasic
CHDIR ".\programs\samples\thebob\biochart"
|
|
|
|
'****************************************************************************'
|
|
'------------------------- B I O C H A R T . B A S --------------------------'
|
|
'------------- Copyright (C) 2007 by Bob Seguin (Freeware)-------------------'
|
|
'****************************************************************************'
|
|
|
|
DEFINT A-Z
|
|
DECLARE SUB PrintSTRING (x, y, Prnt$)
|
|
DECLARE SUB Graphics ()
|
|
DECLARE SUB ChartGFX ()
|
|
DECLARE SUB Birthday ()
|
|
DECLARE SUB ChartBD ()
|
|
DECLARE SUB PutNUMS (x, Num)
|
|
|
|
DECLARE FUNCTION GetDATE$ ()
|
|
|
|
DIM SHARED NumBOX(300)
|
|
DIM SHARED Box(12000)
|
|
DIM SHARED FontBOX(6000)
|
|
DIM SHARED xBOX(1 TO 9)
|
|
DEF SEG = VARSEG(FontBOX(0))
|
|
BLOAD "brsmssb.fnt", VARPTR(FontBOX(0))
|
|
DEF SEG = VARSEG(NumBOX(0))
|
|
BLOAD "brsnums.bsv", VARPTR(NumBOX(0))
|
|
DEF SEG
|
|
|
|
CONST Degree! = 3.14159 / 180
|
|
CONST Physical! = 90 / 23
|
|
CONST Emotional! = 90 / 28
|
|
CONST Intellectual! = 90 / 33
|
|
CONST Intuitive! = 90 / 38
|
|
|
|
DIM SHARED DATE2$, Birthdate$
|
|
DIM SHARED Hour!
|
|
DIM SHARED Months(1 TO 12) AS INTEGER
|
|
RESTORE MonthDATA
|
|
FOR n = 1 TO 12: READ Months(n): NEXT n
|
|
RESTORE xDATA
|
|
FOR n = 1 TO 8: READ xBOX(n): NEXT n
|
|
|
|
SCREEN 12
|
|
GOSUB SetPALETTE
|
|
DATE2$ = DATE$
|
|
|
|
Graphics
|
|
Birthday
|
|
|
|
DO
|
|
k$ = UCASE$(INKEY$)
|
|
SELECT CASE k$
|
|
CASE "B"
|
|
PUT (162, 176), Box, PSET
|
|
B$ = GetDATE$
|
|
IF B$ = "NULL" THEN
|
|
SYSTEM
|
|
ELSE
|
|
Birthdate$ = B$
|
|
ChartBD
|
|
END IF
|
|
CASE "T"
|
|
PUT (162, 181), Box(3500), PSET
|
|
B$ = GetDATE$
|
|
IF B$ = "NULL" THEN DATE2$ = DATE$ ELSE DATE2$ = B$
|
|
LINE (194, 419)-(294, 434), 0, BF
|
|
PrintSTRING 196, 420, "DATE: " + DATE2$
|
|
ChartBD
|
|
CASE CHR$(27): EXIT DO
|
|
END SELECT
|
|
LOOP
|
|
|
|
SYSTEM
|
|
|
|
xDATA:
|
|
DATA 379, 386, 402, 409, 425, 432, 439, 446
|
|
|
|
MonthDATA:
|
|
DATA 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31
|
|
|
|
SetPALETTE:
|
|
RESTORE SetPALETTE
|
|
DATA 0, 0, 21, 21, 8, 43, 24, 10, 48, 26, 11, 53
|
|
DATA 28,12,58, 32, 13, 63, 63, 63, 21, 42, 42, 42
|
|
DATA 63, 0, 0, 21, 31, 63, 52, 41, 63, 55, 55, 55
|
|
DATA 0, 0, 42, 63, 21, 63, 32, 32, 42, 63, 63, 63
|
|
RESTORE SetPALETTE
|
|
OUT &H3C8, 0
|
|
FOR n = 1 TO 48
|
|
READ Colr
|
|
OUT &H3C9, Colr
|
|
NEXT n
|
|
RETURN
|
|
|
|
SUB Birthday
|
|
|
|
OPEN "brbd.dta" FOR BINARY AS #1
|
|
IF LOF(1) THEN
|
|
CLOSE #1
|
|
OPEN "brbd.dta" FOR INPUT AS #1
|
|
INPUT #1, Birthdate$
|
|
CLOSE #1
|
|
ELSE
|
|
CLOSE #1
|
|
PUT (162, 176), Box, PSET
|
|
B$ = GetDATE$
|
|
IF B$ = "NULL" THEN
|
|
SYSTEM
|
|
ELSE
|
|
Birthdate$ = B$
|
|
END IF
|
|
END IF
|
|
ChartBD
|
|
|
|
END SUB
|
|
|
|
SUB ChartBD
|
|
|
|
LINE (220, 89)-(420, 102), 0, BF
|
|
PrintSTRING 240, 89, "For a person born"
|
|
PrintSTRING 340, 89, Birthdate$
|
|
OPEN "brbd.dta" FOR OUTPUT AS #1
|
|
PRINT #1, Birthdate$
|
|
CLOSE #1
|
|
ChartGFX
|
|
|
|
Hour! = VAL(MID$(TIME$, 1, 2)) * .83
|
|
LINE (310 + Hour!, 110)-(310 + Hour!, 426), 11
|
|
LINE (310 + Hour!, 426)-(338, 426), 11
|
|
PSET (310, 410), 7: DRAW "D16L12"
|
|
|
|
Month$ = MID$(DATE2$, 1, 2)
|
|
Day$ = MID$(DATE2$, 4, 2)
|
|
Year$ = MID$(DATE2$, 7, 4)
|
|
M$ = MID$(Birthdate$, 1, 2)
|
|
D$ = MID$(Birthdate$, 4, 2)
|
|
y$ = MID$(Birthdate$, 7, 4)
|
|
FirstMONTH = Months(VAL(M$)) - VAL(D$) + 1
|
|
FOR n = (VAL(M$) + 1) TO 12
|
|
BalMONTHS = BalMONTHS + Months(n)
|
|
IF n = 2 AND ((VAL(y$) MOD 4) = 0) THEN BalMONTHS = BalMONTHS + 1
|
|
NEXT n
|
|
FirstYEAR = FirstMONTH + BalMONTHS
|
|
FOR n = (VAL(y$) + 1) TO (VAL(Year$) - 1)
|
|
IF n MOD 4 = 0 THEN Yr = 366 ELSE Yr = 365
|
|
TDays = TDays + Yr
|
|
NEXT n
|
|
TDays = TDays + FirstYEAR
|
|
|
|
FOR n = 1 TO VAL(Month$) - 1
|
|
Days = Days + Months(n)
|
|
IF n = 2 THEN
|
|
IF VAL(Year$) MOD 4 = 0 THEN Days = Days + 1
|
|
END IF
|
|
NEXT n
|
|
|
|
TDays = TDays + Days + VAL(Day$) - 1
|
|
|
|
VIEW SCREEN (10, 110)-(630, 410)
|
|
|
|
'EMOTIONAL
|
|
PreviousX = 320 - (((TDays MOD 28) + 28) * 20)
|
|
PreviousY = 260
|
|
C! = 0
|
|
FOR x = 320 - (((TDays MOD 28) + 28) * 20) TO 630 STEP 5
|
|
LINE (PreviousX, PreviousY)-(x, 260 + SIN(C! * Degree!) * 150), 8
|
|
PreviousX = x
|
|
PreviousY = 260 + SIN(C! * Degree!) * 150
|
|
C! = C! - Emotional!
|
|
NEXT x
|
|
|
|
'INTELLECTUAL
|
|
PreviousX = 320 - (((TDays MOD 33) + 33) * 20)
|
|
PreviousY = 260
|
|
C! = 0
|
|
FOR x = 320 - (((TDays MOD 33) + 33) * 20) TO 630 STEP 5
|
|
LINE (PreviousX, PreviousY)-(x, 260 + SIN(C! * Degree!) * 150), 6
|
|
PreviousX = x
|
|
PreviousY = 260 + SIN(C! * Degree!) * 150
|
|
C! = C! - Intellectual!
|
|
NEXT x
|
|
|
|
PreviousX = 10
|
|
PreviousY = 260
|
|
C! = 0
|
|
'PHYSICAL
|
|
PreviousX = 320 - (((TDays MOD 23) + 23) * 20)
|
|
PreviousY = 250
|
|
FOR x = 320 - (((TDays MOD 23) + 23) * 20) TO 630 STEP 5
|
|
LINE (PreviousX, PreviousY)-(x, 260 + SIN(C! * Degree!) * 150), 9
|
|
PreviousX = x
|
|
PreviousY = 260 + SIN(C! * Degree!) * 150
|
|
C! = C! - Physical!
|
|
NEXT x
|
|
|
|
|
|
'INTUITIVE
|
|
PreviousX = 320 - (((TDays MOD 38) + 38) * 20)
|
|
PreviousY = 260
|
|
C! = 0
|
|
FOR x = 320 - (((TDays MOD 38) + 38) * 20) TO 630 STEP 5
|
|
LINE (PreviousX, PreviousY)-(x, 260 + SIN(C! * Degree!) * 150), 13
|
|
PreviousX = x
|
|
PreviousY = 260 + SIN(C! * Degree!) * 150
|
|
C! = C! - Intuitive!
|
|
NEXT x
|
|
|
|
VIEW
|
|
|
|
END SUB
|
|
|
|
DEFSNG A-Z
|
|
SUB ChartGFX
|
|
|
|
LINE (5, 106)-(634, 414), 7, BF
|
|
LINE (9, 109)-(631, 170), 1, BF
|
|
LINE (9, 170)-(631, 230), 2, BF
|
|
LINE (9, 230)-(631, 290), 3, BF
|
|
LINE (9, 290)-(631, 350), 2, BF
|
|
LINE (9, 350)-(631, 411), 1, BF
|
|
LINE (9, 109)-(631, 411), 7, B
|
|
FOR x = 30 TO 610 STEP 20
|
|
LINE (x, 110)-(x, 410), 7
|
|
IF x = 330 THEN PAINT (x - 10, 260), 7
|
|
NEXT x
|
|
LINE (10, 260)-(630, 260), 7
|
|
|
|
END SUB
|
|
|
|
DEFINT A-Z
|
|
FUNCTION GetDATE$
|
|
i = 1: Interval! = .25: Colr = 15
|
|
DO
|
|
WAIT &H3DA, 8: WAIT &H3DA, 8, 8
|
|
IF i < 9 THEN LINE (xBOX(i) + 1, 201)-(xBOX(i) + 6, 202), Colr, B
|
|
k$ = INKEY$
|
|
SELECT CASE k$
|
|
CASE "0" TO "9"
|
|
IF i < 9 THEN
|
|
LINE (xBOX(i) + 1, 201)-(xBOX(i) + 6, 202), 15, BF
|
|
PutNUMS xBOX(i), VAL(k$)
|
|
D$ = D$ + k$
|
|
i = i + 1
|
|
END IF
|
|
CASE CHR$(13) 'Enter
|
|
IF LEN(D$) = 8 THEN
|
|
mm$ = MID$(D$, 1, 2)
|
|
dd$ = MID$(D$, 3, 2)
|
|
yy$ = MID$(D$, 5, 4)
|
|
IF VAL(mm$) > 0 AND VAL(mm$) < 13 THEN
|
|
IF VAL(dd$) > 0 AND VAL(dd$) < 32 THEN
|
|
IF VAL(yy$) > 1900 AND VAL(yy$) < 3000 THEN
|
|
GetDATE$ = mm$ + "-" + dd$ + "-" + yy$
|
|
ELSE
|
|
GetDATE$ = "NULL"
|
|
END IF
|
|
ELSE
|
|
GetDATE$ = "NULL"
|
|
END IF
|
|
ELSE
|
|
GetDATE$ = "NULL"
|
|
END IF
|
|
ELSE
|
|
GetDATE$ = "NULL"
|
|
END IF
|
|
EXIT FUNCTION
|
|
CASE CHR$(8) 'Backspace
|
|
IF i > 1 THEN
|
|
IF i < 9 THEN LINE (xBOX(i), 193)-(xBOX(i) + 6, 202), 15, BF
|
|
i = i - 1
|
|
LINE (xBOX(i), 193)-(xBOX(i) + 6, 202), 15, BF
|
|
D$ = MID$(D$, 1, LEN(D$) - 1)
|
|
END IF
|
|
END SELECT
|
|
|
|
IF TIMER > StartTIME! + Interval! THEN
|
|
StartTIME! = TIMER
|
|
IF Colr = 15 THEN Colr = 7 ELSE Colr = 15
|
|
END IF
|
|
|
|
LOOP
|
|
|
|
END FUNCTION
|
|
|
|
SUB Graphics
|
|
DEF SEG = VARSEG(Box(0))
|
|
BLOAD "brsheads.bsv", VARPTR(Box(0))
|
|
DEF SEG
|
|
PUT (78, 32), Box
|
|
PUT (20, 440), Box(7000)
|
|
PUT (10, 6), Box(10000)
|
|
PUT (500, 6), Box(11200)
|
|
|
|
PrintSTRING 196, 420, "DATE: " + DATE2$
|
|
PrintSTRING 342, 420, "TIME: " + TIME$
|
|
PrintSTRING 12, 460, "Press [B] to enter a new birth date"
|
|
PrintSTRING 270, 460, "Press [T] to enter a target date"
|
|
PrintSTRING 520, 460, "Press [ESC] to QUIT"
|
|
|
|
ChartGFX
|
|
|
|
DEF SEG = VARSEG(Box(0))
|
|
BLOAD "brsinpt.bsv", VARPTR(Box(0))
|
|
DEF SEG
|
|
|
|
END SUB
|
|
|
|
SUB PrintSTRING (x, y, Prnt$)
|
|
|
|
FOR i = 1 TO LEN(Prnt$)
|
|
Char$ = MID$(Prnt$, i, 1)
|
|
IF Char$ = " " THEN
|
|
x = x + FontBOX(1)
|
|
ELSE
|
|
Index = (ASC(Char$) - 33) * FontBOX(0) + 2
|
|
PUT (x, y), FontBOX(Index)
|
|
x = x + FontBOX(Index)
|
|
END IF
|
|
NEXT i
|
|
|
|
END SUB
|
|
|
|
SUB PutNUMS (x, Num)
|
|
PUT (x, 191), NumBOX(Num * 30)
|
|
END SUB
|