math/biorythm/bio.bas

   1 CHDIR ".\qbasicapps\math\biorythm"\r
   2 \r
   3 \r
   4 ' Biorythm calculator\r
   5 ' made by Svjatoslav Agejenko\r
   6 ' in 2003.12\r
   7 ' email: svjatoslav@svjatoslav.eu\r
   8 \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
  21 DECLARE SUB quit ()\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
  28 \r
  29 DEFLNG A-Y\r
  30 \r
  31 DIM SHARED mitus, sona$(1 TO 50)\r
  32 DIM SHARED pi\r
  33 \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
  38 DIM SHARED humamo\r
  39 DIM SHARED modi\r
  40 \r
  41 DIM SHARED curry\r
  42 DIM SHARED currm\r
  43 DIM SHARED currd\r
  44 \r
  45 DIM SHARED colstd\r
  46 DIM SHARED colusr\r
  47 \r
  48 \r
  49 start\r
  50 \r
  51 cmdline\r
  52 \r
  53 SUB cmd (a$)\r
  54 IF a$ = SPACE$(LEN(a$)) THEN GOTO 2\r
  55 getson a$\r
  56 \r
  57 SELECT CASE sona$(1)\r
  58 CASE "help"\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
  70 \r
  71   COLOR getcol(255, 0, 0)\r
  72   PRINT "physical";\r
  73   COLOR getcol(0, 255, 0)\r
  74   PRINT " emotional";\r
  75   COLOR getcol(0, 0, 255)\r
  76   PRINT " intellectual"\r
  77   COLOR getcol(255, 255, 0)\r
  78   PRINT "o-sunday"\r
  79 \r
  80 \r
  81 CASE "about"\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
  87 CASE "bye"\r
  88   quit\r
  89 CASE "add"\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
  92   FOR a = 1 TO humamo\r
  93     IF humnick$(a) = sona$(2) THEN PRINT "such name already exists": GOTO 2\r
  94   NEXT a\r
  95   humamo = humamo + 1\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
 100   modi = 1\r
 101 CASE "who"\r
 102   IF humamo = 0 THEN\r
 103     PRINT "no humans in database"\r
 104   ELSE\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
 110     COLOR c\r
 111     FOR b = 1 TO 5\r
 112       PRINT CHR$(219);\r
 113     NEXT b\r
 114     COLOR colstd\r
 115     PRINT humby(a); humbm(a); humbd(a)\r
 116   NEXT a\r
 117   END IF\r
 118 CASE "clear"\r
 119   humamo = 0\r
 120   modi = 1\r
 121 CASE "rm"\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
 129       GOTO 2\r
 130     END IF\r
 131   NEXT a\r
 132   PRINT "such human not found in list"\r
 133 CASE "today"\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
 137       GOTO 2\r
 138     END IF\r
 139   NEXT a\r
 140   PRINT "such human not found in list"\r
 141 CASE "look"\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
 145       GOTO 2\r
 146     END IF\r
 147   NEXT a\r
 148   PRINT "such human not found in list"\r
 149 CASE ELSE\r
 150   PRINT "unknown command> " + a$\r
 151 END SELECT\r
 152 2\r
 153 END SUB\r
 154 \r
 155 SUB cmdline\r
 156 \r
 157 1\r
 158 COLOR colusr\r
 159 LINE INPUT a$\r
 160 COLOR colstd\r
 161 \r
 162 cmd a$\r
 163 GOTO 1\r
 164 END SUB\r
 165 \r
 166 SUB dispgraph (sday, dday)\r
 167 FOR a = 1 TO 6\r
 168   PRINT ""\r
 169 NEXT a\r
 170 \r
 171 LINE (0, 145)-(319, 190), 1, BF\r
 172 h = (145 + 190) / 2\r
 173 \r
 174 LINE (0, h)-(319, h), getcol(0, 0, 80)\r
 175 \r
 176 FOR x = 3 TO 319 STEP 8\r
 177 NEXT x\r
 178 \r
 179 ttime = dday - sday\r
 180 \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
 185 \r
 186 FOR x = 1 TO 319\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
 191     ELSE\r
 192       LINE (x, 145)-(x, 190), getcol(100, 100, 100)\r
 193     END IF\r
 194     IF (zt + sday) MOD 7 = 6 THEN CIRCLE (x, 145), 2, getcol(255, 255, 0)\r
 195   END IF\r
 196   getdata zt, y1, y2, y3\r
 197   c = getcol((y1 + 100) * 1.25, (y2 + 100) * 1.25, (y3 + 100) * 1.25)\r
 198   PSET (x, h + 1), c\r
 199   PSET (x, h - 1), c\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
 203   PSET (x - 1, h), c\r
 204   oy1 = y1\r
 205   oy2 = y2\r
 206   oy3 = y3\r
 207 NEXT x\r
 208 \r
 209 END SUB\r
 210 \r
 211 DEFLNG Z\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
 220 END FUNCTION\r
 221 \r
 222 DEFSNG Z\r
 223 SUB getdata (zt, y1, y2, y3)\r
 224 y1 = gety(zt, 23)\r
 225 y2 = gety(zt, 28)\r
 226 y3 = gety(zt, 33)\r
 227 END SUB\r
 228 \r
 229 DEFLNG Z\r
 230 FUNCTION getday (y, m, d)\r
 231 r = d\r
 232 FOR a = 1600 TO y - 1\r
 233   r = r + 365\r
 234   IF a \ 4 = a / 4 THEN r = r + 1\r
 235 NEXT a\r
 236 \r
 237 FOR a = 1 TO m - 1\r
 238   r = r + mdays(y, a)\r
 239 NEXT a\r
 240 \r
 241 getday = r\r
 242 END FUNCTION\r
 243 \r
 244 SUB getson (a$)\r
 245 mitus = 0\r
 246 \r
 247 d = 1\r
 248 FOR b = 1 TO LEN(a$)\r
 249 c$ = RIGHT$(LEFT$(a$, b), 1)\r
 250 IF c$ = " " THEN\r
 251 d = 1\r
 252 ELSE\r
 253 IF d = 1 THEN\r
 254 mitus = mitus + 1\r
 255 sona$(mitus) = ""\r
 256 d = 0\r
 257 END IF\r
 258 sona$(mitus) = sona$(mitus) + c$\r
 259 END IF\r
 260 NEXT b\r
 261 \r
 262 END SUB\r
 263 \r
 264 DEFSNG Z\r
 265 FUNCTION gety (zx2, re)\r
 266 zx1 = zx2\r
 267 9\r
 268 IF zx1 > (re * 100) THEN zx1 = zx1 - (re * 100): GOTO 9\r
 269 8       \r
 270 IF zx1 > (re * 10) THEN zx1 = zx1 - (re * 10): GOTO 8\r
 271 7\r
 272 IF zx1 >= re THEN zx1 = zx1 - re: GOTO 7\r
 273 \r
 274 zx1 = zx1 * (100 / re)\r
 275 \r
 276 IF zx1 MOD 100 < 50 THEN s = 100 ELSE s = -100\r
 277 zx = zx1 * 2 MOD 100\r
 278 IF zx < 88 THEN\r
 279   gety = SIN(zx / 52) * s\r
 280 ELSE\r
 281   gety = SIN(pi / 2 + (zx - 88) / 6.7) * s\r
 282 END IF\r
 283 END FUNCTION\r
 284 \r
 285 DEFLNG Z\r
 286 SUB listload\r
 287 OPEN "ppl.txt" FOR INPUT AS #1\r
 288 6\r
 289 IF EOF(1) <> 0 THEN GOTO 5\r
 290 LINE INPUT #1, a$\r
 291 a$ = "add " + a$\r
 292 cmd a$\r
 293 GOTO 6\r
 294 5\r
 295 CLOSE #1\r
 296 END SUB\r
 297 \r
 298 SUB listsave\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
 302   NEXT a\r
 303 CLOSE #1\r
 304 PRINT "list updated"\r
 305 END SUB\r
 306 \r
 307 FUNCTION mdays (y, m)\r
 308 \r
 309 SELECT CASE m\r
 310 CASE 1\r
 311   r = 31\r
 312 CASE 2\r
 313   IF y / 4 = y \ 4 THEN r = 29 ELSE r = 28\r
 314 CASE 3\r
 315   r = 31\r
 316 CASE 4\r
 317   r = 30\r
 318 CASE 5\r
 319   r = 31\r
 320 CASE 6\r
 321   r = 30\r
 322 CASE 7\r
 323   r = 31\r
 324 CASE 8\r
 325   r = 31\r
 326 CASE 9\r
 327   r = 30\r
 328 CASE 10\r
 329   r = 31\r
 330 CASE 11\r
 331   r = 30\r
 332 CASE 12\r
 333   r = 31\r
 334 END SELECT\r
 335 \r
 336 mdays = r\r
 337 END FUNCTION\r
 338 \r
 339 SUB quit\r
 340 \r
 341 IF modi <> 0 THEN\r
 342 4\r
 343   PRINT "Known humans list is modified,"\r
 344   PRINT "save modifications ? (y/n)"\r
 345   a$ = INPUT$(1)\r
 346   IF a$ = "n" THEN GOTO 3\r
 347   IF a$ <> "y" THEN GOTO 4\r
 348   listsave\r
 349 END IF\r
 350 \r
 351 3\r
 352 SYSTEM\r
 353 END SUB\r
 354 \r
 355 SUB setupal\r
 356 c = 0\r
 357 FOR r = 0 TO 5\r
 358 FOR g = 0 TO 5\r
 359 FOR b = 0 TO 5\r
 360 OUT &H3C8, c\r
 361 c = c + 1\r
 362 OUT &H3C9, r * 12\r
 363 OUT &H3C9, g * 12\r
 364 OUT &H3C9, b * 12\r
 365 NEXT b\r
 366 NEXT g\r
 367 NEXT r\r
 368 END SUB\r
 369 \r
 370 DEFSNG Z\r
 371 SUB start\r
 372 a$ = DATE$\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
 378 \r
 379 \r
 380 pi = 3.1415\r
 381 humamo = 0\r
 382 \r
 383 SCREEN 13\r
 384 VIEW PRINT 1 TO 25\r
 385 setupal\r
 386 COLOR colstd\r
 387 \r
 388 \r
 389 FOR a = 1 TO 30\r
 390   PRINT ""\r
 391 NEXT a\r
 392 \r
 393 cmd "about"\r
 394 \r
 395 listload\r
 396 modi = 0\r
 397 \r
 398 \r
 399 \r
 400 END SUB\r
 401 \r