math/biorythm/bio.bas

   1 ' Biorythm calculator\r
   2 ' made by Svjatoslav Agejenko\r
   3 ' in 2003.12\r
   4 ' email: svjatoslavagejenko@gmail.com\r
   5 \r
   6 DECLARE FUNCTION gety& (zx2!, re&)\r
   7 DECLARE SUB getdata (zt!, y1&, y2&, y3&)\r
   8 DECLARE SUB dispgraph (sday&, dday&)\r
   9 DECLARE FUNCTION getday& (y&, m&, d&)\r
  10 DECLARE FUNCTION mdays& (y&, m&)\r
  11 DECLARE FUNCTION getcol& (r&, g&, b&)\r
  12 DECLARE FUNCTION getcolor& (r&, g&, b&)\r
  13 DECLARE FUNCTION geth& (x1&)\r
  14 DECLARE FUNCTION absday! (y!, m!, d!)\r
  15 DECLARE SUB listload ()\r
  16 DECLARE SUB listsave ()\r
  17 DECLARE SUB savelist ()\r
  18 DECLARE SUB quit ()\r
  19 DECLARE SUB getson (a$)\r
  20 DECLARE SUB cmd (a$)\r
  21 DECLARE SUB cmdline ()\r
  22 DECLARE SUB setupal ()\r
  23 DECLARE SUB loadfont ()\r
  24 DECLARE SUB start ()\r
  25 \r
  26 DEFLNG A-Y\r
  27 \r
  28 DIM SHARED mitus, sona$(1 TO 50)\r
  29 DIM SHARED pi\r
  30 \r
  31 DIM SHARED humnick$(1 TO 100)\r
  32 DIM SHARED humby(1 TO 100)\r
  33 DIM SHARED humbm(1 TO 100)\r
  34 DIM SHARED humbd(1 TO 100)\r
  35 DIM SHARED humamo\r
  36 DIM SHARED modi\r
  37 \r
  38 DIM SHARED curry\r
  39 DIM SHARED currm\r
  40 DIM SHARED currd\r
  41 \r
  42 DIM SHARED colstd\r
  43 DIM SHARED colusr\r
  44 \r
  45 \r
  46 start\r
  47 \r
  48 cmdline\r
  49 \r
  50 SUB cmd (a$)\r
  51 IF a$ = SPACE$(LEN(a$)) THEN GOTO 2\r
  52 getson a$\r
  53 \r
  54 SELECT CASE sona$(1)\r
  55 CASE "help"\r
  56   PRINT "about   - display banner"\r
  57   PRINT "help    - get help"\r
  58   PRINT "bye     - quit program"\r
  59   PRINT "who     - display list of known peoples"\r
  60   PRINT "add name birtyear birthmonth birthday"\r
  61   PRINT "        - add new human to list"\r
  62   PRINT "rm name - remove human from list"\r
  63   PRINT "clear   - clear humans list"\r
  64   PRINT "today name - show biorythm for today"\r
  65   PRINT "look name year month day"\r
  66   PRINT "        - show biorythm for given day"\r
  67 \r
  68   COLOR getcol(255, 0, 0)\r
  69   PRINT "physical";\r
  70   COLOR getcol(0, 255, 0)\r
  71   PRINT " emotional";\r
  72   COLOR getcol(0, 0, 255)\r
  73   PRINT " intellectual"\r
  74   COLOR getcol(255, 255, 0)\r
  75   PRINT "o-sunday"\r
  76 \r
  77 \r
  78 CASE "about"\r
  79   PRINT "Biorythm calculator, by"\r
  80   PRINT "Svjatoslav Agejenko: n0@hot.ee"\r
  81   PRINT "2003.July.07"\r
  82   PRINT "current date:"; curry; currm; currd\r
  83   PRINT "type 'help' to get help"\r
  84 CASE "bye"\r
  85   quit\r
  86 CASE "add"\r
  87   IF humamo = 100 THEN PRINT "too mutch peoples in database": GOTO 2\r
  88   IF LEN(sona$(2)) > 12 THEN PRINT "Name too long. Use short nicknames.": GOTO 2\r
  89   FOR a = 1 TO humamo\r
  90     IF humnick$(a) = sona$(2) THEN PRINT "such name already exists": GOTO 2\r
  91   NEXT a\r
  92   humamo = humamo + 1\r
  93   humnick$(humamo) = sona$(2)\r
  94   humby(humamo) = VAL(sona$(3))\r
  95   humbm(humamo) = VAL(sona$(4))\r
  96   humbd(humamo) = VAL(sona$(5))\r
  97   modi = 1\r
  98 CASE "who"\r
  99   IF humamo = 0 THEN\r
 100     PRINT "no humans in database"\r
 101   ELSE\r
 102   FOR a = 1 TO humamo\r
 103     PRINT humnick$(a) + SPACE$(15 - LEN(humnick$(a)));\r
 104     ztt = getday(curry, currm, currd) - getday(humby(a), humbm(a), humbd(a))\r
 105     getdata ztt, y1, y2, y3\r
 106     c = getcol((y1 + 100) * 1.25, (y2 + 100) * 1.25, (y3 + 100) * 1.25)\r
 107     COLOR c\r
 108     FOR b = 1 TO 5\r
 109       PRINT CHR$(219);\r
 110     NEXT b\r
 111     COLOR colstd\r
 112     PRINT humby(a); humbm(a); humbd(a)\r
 113   NEXT a\r
 114   END IF\r
 115 CASE "clear"\r
 116   humamo = 0\r
 117   modi = 1\r
 118 CASE "rm"\r
 119   FOR a = 1 TO humamo\r
 120     IF sona$(2) = humnick$(a) THEN\r
 121       humnick$(a) = humnick$(humamo)\r
 122       humby(a) = humby(humamo)\r
 123       humbm(a) = humbm(humamo)\r
 124       humbd(a) = humbd(humamo)\r
 125       humamo = humamo - 1\r
 126       GOTO 2\r
 127     END IF\r
 128   NEXT a\r
 129   PRINT "such human not found in list"\r
 130 CASE "today"\r
 131   FOR a = 1 TO humamo\r
 132     IF sona$(2) = humnick$(a) THEN\r
 133       dispgraph getday(humby(a), humbm(a), humbd(a)), getday(curry, currm, currd)\r
 134       GOTO 2\r
 135     END IF\r
 136   NEXT a\r
 137   PRINT "such human not found in list"\r
 138 CASE "look"\r
 139   FOR a = 1 TO humamo\r
 140     IF sona$(2) = humnick$(a) THEN\r
 141       dispgraph getday(humby(a), humbm(a), humbd(a)), getday(VAL(sona$(3)), VAL(sona$(4)), VAL(sona$(5)))\r
 142       GOTO 2\r
 143     END IF\r
 144   NEXT a\r
 145   PRINT "such human not found in list"\r
 146 CASE ELSE\r
 147   PRINT "unknown command> " + a$\r
 148 END SELECT\r
 149 2\r
 150 END SUB\r
 151 \r
 152 SUB cmdline\r
 153 \r
 154 1\r
 155 COLOR colusr\r
 156 LINE INPUT a$\r
 157 COLOR colstd\r
 158 \r
 159 cmd a$\r
 160 GOTO 1\r
 161 END SUB\r
 162 \r
 163 SUB dispgraph (sday, dday)\r
 164 FOR a = 1 TO 6\r
 165   PRINT ""\r
 166 NEXT a\r
 167 \r
 168 LINE (0, 145)-(319, 190), 1, BF\r
 169 h = (145 + 190) / 2\r
 170 \r
 171 LINE (0, h)-(319, h), getcol(0, 0, 80)\r
 172 \r
 173 FOR x = 3 TO 319 STEP 8\r
 174 NEXT x\r
 175 \r
 176 ttime = dday - sday\r
 177 \r
 178 clr1 = getcol(255, 0, 0)\r
 179 clr2 = getcol(0, 255, 0)\r
 180 clr3 = getcol(0, 0, 255)\r
 181 w = getcol(255, 255, 255)\r
 182 \r
 183 FOR x = 1 TO 319\r
 184   zt = x / 8 + ttime - 10\r
 185   IF zt = INT(zt) THEN\r
 186     IF zt + sday = dday THEN\r
 187       LINE (x, 145)-(x, 190), getcol(200, 200, 0)\r
 188     ELSE\r
 189       LINE (x, 145)-(x, 190), getcol(100, 100, 100)\r
 190     END IF\r
 191     IF (zt + sday) MOD 7 = 6 THEN CIRCLE (x, 145), 2, getcol(255, 255, 0)\r
 192   END IF\r
 193   getdata zt, y1, y2, y3\r
 194   c = getcol((y1 + 100) * 1.25, (y2 + 100) * 1.25, (y3 + 100) * 1.25)\r
 195   PSET (x, h + 1), c\r
 196   PSET (x, h - 1), c\r
 197   LINE (x, h - y1 / 5)-(x - 1, h - oy1 / 5), clr1\r
 198   LINE (x, h - y2 / 5)-(x - 1, h - oy2 / 5), clr2\r
 199   LINE (x, h - y3 / 5)-(x - 1, h - oy3 / 5), clr3\r
 200   PSET (x - 1, h), c\r
 201   oy1 = y1\r
 202   oy2 = y2\r
 203   oy3 = y3\r
 204 NEXT x\r
 205 \r
 206 END SUB\r
 207 \r
 208 DEFLNG Z\r
 209 FUNCTION getcol (r, g, b)\r
 210 IF r < 0 THEN r = 0\r
 211 IF g < 0 THEN g = 0\r
 212 IF b < 0 THEN b = 0\r
 213 IF r > 255 THEN r = 255\r
 214 IF g > 255 THEN g = 255\r
 215 IF b > 255 THEN b = 255\r
 216 getcol = INT(r / 43) * 36 + INT(g / 43) * 6 + INT(b / 43)\r
 217 END FUNCTION\r
 218 \r
 219 DEFSNG Z\r
 220 SUB getdata (zt, y1, y2, y3)\r
 221 y1 = gety(zt, 23)\r
 222 y2 = gety(zt, 28)\r
 223 y3 = gety(zt, 33)\r
 224 END SUB\r
 225 \r
 226 DEFLNG Z\r
 227 FUNCTION getday (y, m, d)\r
 228 r = d\r
 229 FOR a = 1600 TO y - 1\r
 230   r = r + 365\r
 231   IF a \ 4 = a / 4 THEN r = r + 1\r
 232 NEXT a\r
 233 \r
 234 FOR a = 1 TO m - 1\r
 235   r = r + mdays(y, a)\r
 236 NEXT a\r
 237 \r
 238 getday = r\r
 239 END FUNCTION\r
 240 \r
 241 SUB getson (a$)\r
 242 mitus = 0\r
 243 \r
 244 d = 1\r
 245 FOR b = 1 TO LEN(a$)\r
 246 c$ = RIGHT$(LEFT$(a$, b), 1)\r
 247 IF c$ = " " THEN\r
 248 d = 1\r
 249 ELSE\r
 250 IF d = 1 THEN\r
 251 mitus = mitus + 1\r
 252 sona$(mitus) = ""\r
 253 d = 0\r
 254 END IF\r
 255 sona$(mitus) = sona$(mitus) + c$\r
 256 END IF\r
 257 NEXT b\r
 258 \r
 259 END SUB\r
 260 \r
 261 DEFSNG Z\r
 262 FUNCTION gety (zx2, re)\r
 263 zx1 = zx2\r
 264 9\r
 265 IF zx1 > (re * 100) THEN zx1 = zx1 - (re * 100): GOTO 9\r
 266 8       \r
 267 IF zx1 > (re * 10) THEN zx1 = zx1 - (re * 10): GOTO 8\r
 268 7\r
 269 IF zx1 >= re THEN zx1 = zx1 - re: GOTO 7\r
 270 \r
 271 zx1 = zx1 * (100 / re)\r
 272 \r
 273 IF zx1 MOD 100 < 50 THEN s = 100 ELSE s = -100\r
 274 zx = zx1 * 2 MOD 100\r
 275 IF zx < 88 THEN\r
 276   gety = SIN(zx / 52) * s\r
 277 ELSE\r
 278   gety = SIN(pi / 2 + (zx - 88) / 6.7) * s\r
 279 END IF\r
 280 END FUNCTION\r
 281 \r
 282 DEFLNG Z\r
 283 SUB listload\r
 284 OPEN "ppl.txt" FOR INPUT AS #1\r
 285 6\r
 286 IF EOF(1) <> 0 THEN GOTO 5\r
 287 LINE INPUT #1, a$\r
 288 a$ = "add " + a$\r
 289 cmd a$\r
 290 GOTO 6\r
 291 5\r
 292 CLOSE #1\r
 293 END SUB\r
 294 \r
 295 SUB listsave\r
 296 OPEN "ppl.txt" FOR OUTPUT AS #1\r
 297   FOR a = 1 TO humamo\r
 298     PRINT #1, humnick$(a); humby(a); humbm(a); humbd(a)\r
 299   NEXT a\r
 300 CLOSE #1\r
 301 PRINT "list updated"\r
 302 END SUB\r
 303 \r
 304 FUNCTION mdays (y, m)\r
 305 \r
 306 SELECT CASE m\r
 307 CASE 1\r
 308   r = 31\r
 309 CASE 2\r
 310   IF y / 4 = y \ 4 THEN r = 29 ELSE r = 28\r
 311 CASE 3\r
 312   r = 31\r
 313 CASE 4\r
 314   r = 30\r
 315 CASE 5\r
 316   r = 31\r
 317 CASE 6\r
 318   r = 30\r
 319 CASE 7\r
 320   r = 31\r
 321 CASE 8\r
 322   r = 31\r
 323 CASE 9\r
 324   r = 30\r
 325 CASE 10\r
 326   r = 31\r
 327 CASE 11\r
 328   r = 30\r
 329 CASE 12\r
 330   r = 31\r
 331 END SELECT\r
 332 \r
 333 mdays = r\r
 334 END FUNCTION\r
 335 \r
 336 SUB quit\r
 337 \r
 338 IF modi <> 0 THEN\r
 339 4\r
 340   PRINT "Known humans list is modified,"\r
 341   PRINT "save modifications ? (y/n)"\r
 342   a$ = INPUT$(1)\r
 343   IF a$ = "n" THEN GOTO 3\r
 344   IF a$ <> "y" THEN GOTO 4\r
 345   listsave\r
 346 END IF\r
 347 \r
 348 3\r
 349 SYSTEM\r
 350 END SUB\r
 351 \r
 352 SUB setupal\r
 353 c = 0\r
 354 FOR r = 0 TO 5\r
 355 FOR g = 0 TO 5\r
 356 FOR b = 0 TO 5\r
 357 OUT &H3C8, c\r
 358 c = c + 1\r
 359 OUT &H3C9, r * 12\r
 360 OUT &H3C9, g * 12\r
 361 OUT &H3C9, b * 12\r
 362 NEXT b\r
 363 NEXT g\r
 364 NEXT r\r
 365 END SUB\r
 366 \r
 367 DEFSNG Z\r
 368 SUB start\r
 369 a$ = DATE$\r
 370 currm = VAL(LEFT$(a$, 2))\r
 371 curry = VAL(RIGHT$(a$, 4))\r
 372 currd = VAL(RIGHT$(LEFT$(a$, 5), 2))\r
 373 colstd = getcol(100, 150, 255)\r
 374 colusr = getcol(0, 255, 0)\r
 375 \r
 376 \r
 377 pi = 3.1415\r
 378 humamo = 0\r
 379 \r
 380 SCREEN 13\r
 381 VIEW PRINT 1 TO 25\r
 382 setupal\r
 383 COLOR colstd\r
 384 \r
 385 \r
 386 FOR a = 1 TO 30\r
 387   PRINT ""\r
 388 NEXT a\r
 389 \r
 390 cmd "about"\r
 391 \r
 392 listload\r
 393 modi = 0\r
 394 \r
 395 \r
 396 \r
 397 END SUB\r
 398 \r