+++ /dev/null
-CHDIR ".\qbasicapps\math\biorythm"\r
-\r
-\r
-' Biorythm calculator\r
-' made by Svjatoslav Agejenko\r
-' in 2003.12\r
-' email: svjatoslav@svjatoslav.eu\r
-\r
-DECLARE FUNCTION gety& (zx2!, re&)\r
-DECLARE SUB getdata (zt!, y1&, y2&, y3&)\r
-DECLARE SUB dispgraph (sday&, dday&)\r
-DECLARE FUNCTION getday& (y&, m&, d&)\r
-DECLARE FUNCTION mdays& (y&, m&)\r
-DECLARE FUNCTION getcol& (r&, g&, b&)\r
-DECLARE FUNCTION getcolor& (r&, g&, b&)\r
-DECLARE FUNCTION geth& (x1&)\r
-DECLARE FUNCTION absday! (y!, m!, d!)\r
-DECLARE SUB listload ()\r
-DECLARE SUB listsave ()\r
-DECLARE SUB savelist ()\r
-DECLARE SUB quit ()\r
-DECLARE SUB getson (a$)\r
-DECLARE SUB cmd (a$)\r
-DECLARE SUB cmdline ()\r
-DECLARE SUB setupal ()\r
-DECLARE SUB loadfont ()\r
-DECLARE SUB start ()\r
-\r
-DEFLNG A-Y\r
-\r
-DIM SHARED mitus, sona$(1 TO 50)\r
-DIM SHARED pi\r
-\r
-DIM SHARED humnick$(1 TO 100)\r
-DIM SHARED humby(1 TO 100)\r
-DIM SHARED humbm(1 TO 100)\r
-DIM SHARED humbd(1 TO 100)\r
-DIM SHARED humamo\r
-DIM SHARED modi\r
-\r
-DIM SHARED curry\r
-DIM SHARED currm\r
-DIM SHARED currd\r
-\r
-DIM SHARED colstd\r
-DIM SHARED colusr\r
-\r
-\r
-start\r
-\r
-cmdline\r
-\r
-SUB cmd (a$)\r
-IF a$ = SPACE$(LEN(a$)) THEN GOTO 2\r
-getson a$\r
-\r
-SELECT CASE sona$(1)\r
-CASE "help"\r
- PRINT "about - display banner"\r
- PRINT "help - get help"\r
- PRINT "bye - quit program"\r
- PRINT "who - display list of known peoples"\r
- PRINT "add name birtyear birthmonth birthday"\r
- PRINT " - add new human to list"\r
- PRINT "rm name - remove human from list"\r
- PRINT "clear - clear humans list"\r
- PRINT "today name - show biorythm for today"\r
- PRINT "look name year month day"\r
- PRINT " - show biorythm for given day"\r
-\r
- COLOR getcol(255, 0, 0)\r
- PRINT "physical";\r
- COLOR getcol(0, 255, 0)\r
- PRINT " emotional";\r
- COLOR getcol(0, 0, 255)\r
- PRINT " intellectual"\r
- COLOR getcol(255, 255, 0)\r
- PRINT "o-sunday"\r
-\r
-\r
-CASE "about"\r
- PRINT "Biorythm calculator, by"\r
- PRINT "Svjatoslav Agejenko: n0@hot.ee"\r
- PRINT "2003.July.07"\r
- PRINT "current date:"; curry; currm; currd\r
- PRINT "type 'help' to get help"\r
-CASE "bye"\r
- quit\r
-CASE "add"\r
- IF humamo = 100 THEN PRINT "too mutch peoples in database": GOTO 2\r
- IF LEN(sona$(2)) > 12 THEN PRINT "Name too long. Use short nicknames.": GOTO 2\r
- FOR a = 1 TO humamo\r
- IF humnick$(a) = sona$(2) THEN PRINT "such name already exists": GOTO 2\r
- NEXT a\r
- humamo = humamo + 1\r
- humnick$(humamo) = sona$(2)\r
- humby(humamo) = VAL(sona$(3))\r
- humbm(humamo) = VAL(sona$(4))\r
- humbd(humamo) = VAL(sona$(5))\r
- modi = 1\r
-CASE "who"\r
- IF humamo = 0 THEN\r
- PRINT "no humans in database"\r
- ELSE\r
- FOR a = 1 TO humamo\r
- PRINT humnick$(a) + SPACE$(15 - LEN(humnick$(a)));\r
- ztt = getday(curry, currm, currd) - getday(humby(a), humbm(a), humbd(a))\r
- getdata ztt, y1, y2, y3\r
- c = getcol((y1 + 100) * 1.25, (y2 + 100) * 1.25, (y3 + 100) * 1.25)\r
- COLOR c\r
- FOR b = 1 TO 5\r
- PRINT CHR$(219);\r
- NEXT b\r
- COLOR colstd\r
- PRINT humby(a); humbm(a); humbd(a)\r
- NEXT a\r
- END IF\r
-CASE "clear"\r
- humamo = 0\r
- modi = 1\r
-CASE "rm"\r
- FOR a = 1 TO humamo\r
- IF sona$(2) = humnick$(a) THEN\r
- humnick$(a) = humnick$(humamo)\r
- humby(a) = humby(humamo)\r
- humbm(a) = humbm(humamo)\r
- humbd(a) = humbd(humamo)\r
- humamo = humamo - 1\r
- GOTO 2\r
- END IF\r
- NEXT a\r
- PRINT "such human not found in list"\r
-CASE "today"\r
- FOR a = 1 TO humamo\r
- IF sona$(2) = humnick$(a) THEN\r
- dispgraph getday(humby(a), humbm(a), humbd(a)), getday(curry, currm, currd)\r
- GOTO 2\r
- END IF\r
- NEXT a\r
- PRINT "such human not found in list"\r
-CASE "look"\r
- FOR a = 1 TO humamo\r
- IF sona$(2) = humnick$(a) THEN\r
- dispgraph getday(humby(a), humbm(a), humbd(a)), getday(VAL(sona$(3)), VAL(sona$(4)), VAL(sona$(5)))\r
- GOTO 2\r
- END IF\r
- NEXT a\r
- PRINT "such human not found in list"\r
-CASE ELSE\r
- PRINT "unknown command> " + a$\r
-END SELECT\r
-2\r
-END SUB\r
-\r
-SUB cmdline\r
-\r
-1\r
-COLOR colusr\r
-LINE INPUT a$\r
-COLOR colstd\r
-\r
-cmd a$\r
-GOTO 1\r
-END SUB\r
-\r
-SUB dispgraph (sday, dday)\r
-FOR a = 1 TO 6\r
- PRINT ""\r
-NEXT a\r
-\r
-LINE (0, 145)-(319, 190), 1, BF\r
-h = (145 + 190) / 2\r
-\r
-LINE (0, h)-(319, h), getcol(0, 0, 80)\r
-\r
-FOR x = 3 TO 319 STEP 8\r
-NEXT x\r
-\r
-ttime = dday - sday\r
-\r
-clr1 = getcol(255, 0, 0)\r
-clr2 = getcol(0, 255, 0)\r
-clr3 = getcol(0, 0, 255)\r
-w = getcol(255, 255, 255)\r
-\r
-FOR x = 1 TO 319\r
- zt = x / 8 + ttime - 10\r
- IF zt = INT(zt) THEN\r
- IF zt + sday = dday THEN\r
- LINE (x, 145)-(x, 190), getcol(200, 200, 0)\r
- ELSE\r
- LINE (x, 145)-(x, 190), getcol(100, 100, 100)\r
- END IF\r
- IF (zt + sday) MOD 7 = 6 THEN CIRCLE (x, 145), 2, getcol(255, 255, 0)\r
- END IF\r
- getdata zt, y1, y2, y3\r
- c = getcol((y1 + 100) * 1.25, (y2 + 100) * 1.25, (y3 + 100) * 1.25)\r
- PSET (x, h + 1), c\r
- PSET (x, h - 1), c\r
- LINE (x, h - y1 / 5)-(x - 1, h - oy1 / 5), clr1\r
- LINE (x, h - y2 / 5)-(x - 1, h - oy2 / 5), clr2\r
- LINE (x, h - y3 / 5)-(x - 1, h - oy3 / 5), clr3\r
- PSET (x - 1, h), c\r
- oy1 = y1\r
- oy2 = y2\r
- oy3 = y3\r
-NEXT x\r
-\r
-END SUB\r
-\r
-DEFLNG Z\r
-FUNCTION getcol (r, g, b)\r
-IF r < 0 THEN r = 0\r
-IF g < 0 THEN g = 0\r
-IF b < 0 THEN b = 0\r
-IF r > 255 THEN r = 255\r
-IF g > 255 THEN g = 255\r
-IF b > 255 THEN b = 255\r
-getcol = INT(r / 43) * 36 + INT(g / 43) * 6 + INT(b / 43)\r
-END FUNCTION\r
-\r
-DEFSNG Z\r
-SUB getdata (zt, y1, y2, y3)\r
-y1 = gety(zt, 23)\r
-y2 = gety(zt, 28)\r
-y3 = gety(zt, 33)\r
-END SUB\r
-\r
-DEFLNG Z\r
-FUNCTION getday (y, m, d)\r
-r = d\r
-FOR a = 1600 TO y - 1\r
- r = r + 365\r
- IF a \ 4 = a / 4 THEN r = r + 1\r
-NEXT a\r
-\r
-FOR a = 1 TO m - 1\r
- r = r + mdays(y, a)\r
-NEXT a\r
-\r
-getday = r\r
-END FUNCTION\r
-\r
-SUB getson (a$)\r
-mitus = 0\r
-\r
-d = 1\r
-FOR b = 1 TO LEN(a$)\r
-c$ = RIGHT$(LEFT$(a$, b), 1)\r
-IF c$ = " " THEN\r
-d = 1\r
-ELSE\r
-IF d = 1 THEN\r
-mitus = mitus + 1\r
-sona$(mitus) = ""\r
-d = 0\r
-END IF\r
-sona$(mitus) = sona$(mitus) + c$\r
-END IF\r
-NEXT b\r
-\r
-END SUB\r
-\r
-DEFSNG Z\r
-FUNCTION gety (zx2, re)\r
-zx1 = zx2\r
-9\r
-IF zx1 > (re * 100) THEN zx1 = zx1 - (re * 100): GOTO 9\r
-8 \r
-IF zx1 > (re * 10) THEN zx1 = zx1 - (re * 10): GOTO 8\r
-7\r
-IF zx1 >= re THEN zx1 = zx1 - re: GOTO 7\r
-\r
-zx1 = zx1 * (100 / re)\r
-\r
-IF zx1 MOD 100 < 50 THEN s = 100 ELSE s = -100\r
-zx = zx1 * 2 MOD 100\r
-IF zx < 88 THEN\r
- gety = SIN(zx / 52) * s\r
-ELSE\r
- gety = SIN(pi / 2 + (zx - 88) / 6.7) * s\r
-END IF\r
-END FUNCTION\r
-\r
-DEFLNG Z\r
-SUB listload\r
-OPEN "ppl.txt" FOR INPUT AS #1\r
-6\r
-IF EOF(1) <> 0 THEN GOTO 5\r
-LINE INPUT #1, a$\r
-a$ = "add " + a$\r
-cmd a$\r
-GOTO 6\r
-5\r
-CLOSE #1\r
-END SUB\r
-\r
-SUB listsave\r
-OPEN "ppl.txt" FOR OUTPUT AS #1\r
- FOR a = 1 TO humamo\r
- PRINT #1, humnick$(a); humby(a); humbm(a); humbd(a)\r
- NEXT a\r
-CLOSE #1\r
-PRINT "list updated"\r
-END SUB\r
-\r
-FUNCTION mdays (y, m)\r
-\r
-SELECT CASE m\r
-CASE 1\r
- r = 31\r
-CASE 2\r
- IF y / 4 = y \ 4 THEN r = 29 ELSE r = 28\r
-CASE 3\r
- r = 31\r
-CASE 4\r
- r = 30\r
-CASE 5\r
- r = 31\r
-CASE 6\r
- r = 30\r
-CASE 7\r
- r = 31\r
-CASE 8\r
- r = 31\r
-CASE 9\r
- r = 30\r
-CASE 10\r
- r = 31\r
-CASE 11\r
- r = 30\r
-CASE 12\r
- r = 31\r
-END SELECT\r
-\r
-mdays = r\r
-END FUNCTION\r
-\r
-SUB quit\r
-\r
-IF modi <> 0 THEN\r
-4\r
- PRINT "Known humans list is modified,"\r
- PRINT "save modifications ? (y/n)"\r
- a$ = INPUT$(1)\r
- IF a$ = "n" THEN GOTO 3\r
- IF a$ <> "y" THEN GOTO 4\r
- listsave\r
-END IF\r
-\r
-3\r
-SYSTEM\r
-END SUB\r
-\r
-SUB setupal\r
-c = 0\r
-FOR r = 0 TO 5\r
-FOR g = 0 TO 5\r
-FOR b = 0 TO 5\r
-OUT &H3C8, c\r
-c = c + 1\r
-OUT &H3C9, r * 12\r
-OUT &H3C9, g * 12\r
-OUT &H3C9, b * 12\r
-NEXT b\r
-NEXT g\r
-NEXT r\r
-END SUB\r
-\r
-DEFSNG Z\r
-SUB start\r
-a$ = DATE$\r
-currm = VAL(LEFT$(a$, 2))\r
-curry = VAL(RIGHT$(a$, 4))\r
-currd = VAL(RIGHT$(LEFT$(a$, 5), 2))\r
-colstd = getcol(100, 150, 255)\r
-colusr = getcol(0, 255, 0)\r
-\r
-\r
-pi = 3.1415\r
-humamo = 0\r
-\r
-SCREEN 13\r
-VIEW PRINT 1 TO 25\r
-setupal\r
-COLOR colstd\r
-\r
-\r
-FOR a = 1 TO 30\r
- PRINT ""\r
-NEXT a\r
-\r
-cmd "about"\r
-\r
-listload\r
-modi = 0\r
-\r
-\r
-\r
-END SUB\r
-\r
projects / qbasicapps.git / commitdiff
