1 CHDIR ".\qbasicapps\math\biorythm"
\r
4 ' Biorythm calculator
\r
5 ' made by Svjatoslav Agejenko
\r
7 ' email: svjatoslav@svjatoslav.eu
\r
9 DECLARE FUNCTION gety& (zx2!, re&)
\r
10 DECLARE SUB getdata (zt!, y1&, y2&, y3&)
\r
11 DECLARE SUB dispgraph (sday&, dday&)
\r
12 DECLARE FUNCTION getday& (y&, m&, d&)
\r
13 DECLARE FUNCTION mdays& (y&, m&)
\r
14 DECLARE FUNCTION getcol& (r&, g&, b&)
\r
15 DECLARE FUNCTION getcolor& (r&, g&, b&)
\r
16 DECLARE FUNCTION geth& (x1&)
\r
17 DECLARE FUNCTION absday! (y!, m!, d!)
\r
18 DECLARE SUB listload ()
\r
19 DECLARE SUB listsave ()
\r
20 DECLARE SUB savelist ()
\r
22 DECLARE SUB getson (a$)
\r
23 DECLARE SUB cmd (a$)
\r
24 DECLARE SUB cmdline ()
\r
25 DECLARE SUB setupal ()
\r
26 DECLARE SUB loadfont ()
\r
27 DECLARE SUB start ()
\r
31 DIM SHARED mitus, sona$(1 TO 50)
\r
34 DIM SHARED humnick$(1 TO 100)
\r
35 DIM SHARED humby(1 TO 100)
\r
36 DIM SHARED humbm(1 TO 100)
\r
37 DIM SHARED humbd(1 TO 100)
\r
54 IF a$ = SPACE$(LEN(a$)) THEN GOTO 2
\r
57 SELECT CASE sona$(1)
\r
59 PRINT "about - display banner"
\r
60 PRINT "help - get help"
\r
61 PRINT "bye - quit program"
\r
62 PRINT "who - display list of known peoples"
\r
63 PRINT "add name birtyear birthmonth birthday"
\r
64 PRINT " - add new human to list"
\r
65 PRINT "rm name - remove human from list"
\r
66 PRINT "clear - clear humans list"
\r
67 PRINT "today name - show biorythm for today"
\r
68 PRINT "look name year month day"
\r
69 PRINT " - show biorythm for given day"
\r
71 COLOR getcol(255, 0, 0)
\r
73 COLOR getcol(0, 255, 0)
\r
75 COLOR getcol(0, 0, 255)
\r
76 PRINT " intellectual"
\r
77 COLOR getcol(255, 255, 0)
\r
82 PRINT "Biorythm calculator, by"
\r
83 PRINT "Svjatoslav Agejenko: n0@hot.ee"
\r
84 PRINT "2003.July.07"
\r
85 PRINT "current date:"; curry; currm; currd
\r
86 PRINT "type 'help' to get help"
\r
90 IF humamo = 100 THEN PRINT "too mutch peoples in database": GOTO 2
\r
91 IF LEN(sona$(2)) > 12 THEN PRINT "Name too long. Use short nicknames.": GOTO 2
\r
93 IF humnick$(a) = sona$(2) THEN PRINT "such name already exists": GOTO 2
\r
96 humnick$(humamo) = sona$(2)
\r
97 humby(humamo) = VAL(sona$(3))
\r
98 humbm(humamo) = VAL(sona$(4))
\r
99 humbd(humamo) = VAL(sona$(5))
\r
103 PRINT "no humans in database"
\r
105 FOR a = 1 TO humamo
\r
106 PRINT humnick$(a) + SPACE$(15 - LEN(humnick$(a)));
\r
107 ztt = getday(curry, currm, currd) - getday(humby(a), humbm(a), humbd(a))
\r
108 getdata ztt, y1, y2, y3
\r
109 c = getcol((y1 + 100) * 1.25, (y2 + 100) * 1.25, (y3 + 100) * 1.25)
\r
115 PRINT humby(a); humbm(a); humbd(a)
\r
122 FOR a = 1 TO humamo
\r
123 IF sona$(2) = humnick$(a) THEN
\r
124 humnick$(a) = humnick$(humamo)
\r
125 humby(a) = humby(humamo)
\r
126 humbm(a) = humbm(humamo)
\r
127 humbd(a) = humbd(humamo)
\r
128 humamo = humamo - 1
\r
132 PRINT "such human not found in list"
\r
134 FOR a = 1 TO humamo
\r
135 IF sona$(2) = humnick$(a) THEN
\r
136 dispgraph getday(humby(a), humbm(a), humbd(a)), getday(curry, currm, currd)
\r
140 PRINT "such human not found in list"
\r
142 FOR a = 1 TO humamo
\r
143 IF sona$(2) = humnick$(a) THEN
\r
144 dispgraph getday(humby(a), humbm(a), humbd(a)), getday(VAL(sona$(3)), VAL(sona$(4)), VAL(sona$(5)))
\r
148 PRINT "such human not found in list"
\r
150 PRINT "unknown command> " + a$
\r
166 SUB dispgraph (sday, dday)
\r
171 LINE (0, 145)-(319, 190), 1, BF
\r
172 h = (145 + 190) / 2
\r
174 LINE (0, h)-(319, h), getcol(0, 0, 80)
\r
176 FOR x = 3 TO 319 STEP 8
\r
179 ttime = dday - sday
\r
181 clr1 = getcol(255, 0, 0)
\r
182 clr2 = getcol(0, 255, 0)
\r
183 clr3 = getcol(0, 0, 255)
\r
184 w = getcol(255, 255, 255)
\r
187 zt = x / 8 + ttime - 10
\r
188 IF zt = INT(zt) THEN
\r
189 IF zt + sday = dday THEN
\r
190 LINE (x, 145)-(x, 190), getcol(200, 200, 0)
\r
192 LINE (x, 145)-(x, 190), getcol(100, 100, 100)
\r
194 IF (zt + sday) MOD 7 = 6 THEN CIRCLE (x, 145), 2, getcol(255, 255, 0)
\r
196 getdata zt, y1, y2, y3
\r
197 c = getcol((y1 + 100) * 1.25, (y2 + 100) * 1.25, (y3 + 100) * 1.25)
\r
200 LINE (x, h - y1 / 5)-(x - 1, h - oy1 / 5), clr1
\r
201 LINE (x, h - y2 / 5)-(x - 1, h - oy2 / 5), clr2
\r
202 LINE (x, h - y3 / 5)-(x - 1, h - oy3 / 5), clr3
\r
212 FUNCTION getcol (r, g, b)
\r
213 IF r < 0 THEN r = 0
\r
214 IF g < 0 THEN g = 0
\r
215 IF b < 0 THEN b = 0
\r
216 IF r > 255 THEN r = 255
\r
217 IF g > 255 THEN g = 255
\r
218 IF b > 255 THEN b = 255
\r
219 getcol = INT(r / 43) * 36 + INT(g / 43) * 6 + INT(b / 43)
\r
223 SUB getdata (zt, y1, y2, y3)
\r
230 FUNCTION getday (y, m, d)
\r
232 FOR a = 1600 TO y - 1
\r
234 IF a \ 4 = a / 4 THEN r = r + 1
\r
238 r = r + mdays(y, a)
\r
248 FOR b = 1 TO LEN(a$)
\r
249 c$ = RIGHT$(LEFT$(a$, b), 1)
\r
258 sona$(mitus) = sona$(mitus) + c$
\r
265 FUNCTION gety (zx2, re)
\r
268 IF zx1 > (re * 100) THEN zx1 = zx1 - (re * 100): GOTO 9
\r
270 IF zx1 > (re * 10) THEN zx1 = zx1 - (re * 10): GOTO 8
\r
272 IF zx1 >= re THEN zx1 = zx1 - re: GOTO 7
\r
274 zx1 = zx1 * (100 / re)
\r
276 IF zx1 MOD 100 < 50 THEN s = 100 ELSE s = -100
\r
277 zx = zx1 * 2 MOD 100
\r
279 gety = SIN(zx / 52) * s
\r
281 gety = SIN(pi / 2 + (zx - 88) / 6.7) * s
\r
287 OPEN "ppl.txt" FOR INPUT AS #1
\r
289 IF EOF(1) <> 0 THEN GOTO 5
\r
299 OPEN "ppl.txt" FOR OUTPUT AS #1
\r
300 FOR a = 1 TO humamo
\r
301 PRINT #1, humnick$(a); humby(a); humbm(a); humbd(a)
\r
304 PRINT "list updated"
\r
307 FUNCTION mdays (y, m)
\r
313 IF y / 4 = y \ 4 THEN r = 29 ELSE r = 28
\r
343 PRINT "Known humans list is modified,"
\r
344 PRINT "save modifications ? (y/n)"
\r
346 IF a$ = "n" THEN GOTO 3
\r
347 IF a$ <> "y" THEN GOTO 4
\r
373 currm = VAL(LEFT$(a$, 2))
\r
374 curry = VAL(RIGHT$(a$, 4))
\r
375 currd = VAL(RIGHT$(LEFT$(a$, 5), 2))
\r
376 colstd = getcol(100, 150, 255)
\r
377 colusr = getcol(0, 255, 0)
\r