CHDIR ".\qbasicapps\math\biorythm"


' Biorythm calculator
' made by Svjatoslav Agejenko
' in 2003.12
' email: svjatoslav@svjatoslav.eu

DECLARE FUNCTION gety& (zx2!, re&)
DECLARE SUB getdata (zt!, y1&, y2&, y3&)
DECLARE SUB dispgraph (sday&, dday&)
DECLARE FUNCTION getday& (y&, m&, d&)
DECLARE FUNCTION mdays& (y&, m&)
DECLARE FUNCTION getcol& (r&, g&, b&)
DECLARE FUNCTION getcolor& (r&, g&, b&)
DECLARE FUNCTION geth& (x1&)
DECLARE FUNCTION absday! (y!, m!, d!)
DECLARE SUB listload ()
DECLARE SUB listsave ()
DECLARE SUB savelist ()
DECLARE SUB quit ()
DECLARE SUB getson (a$)
DECLARE SUB cmd (a$)
DECLARE SUB cmdline ()
DECLARE SUB setupal ()
DECLARE SUB loadfont ()
DECLARE SUB start ()

DEFLNG A-Y

DIM SHARED mitus, sona$(1 TO 50)
DIM SHARED pi

DIM SHARED humnick$(1 TO 100)
DIM SHARED humby(1 TO 100)
DIM SHARED humbm(1 TO 100)
DIM SHARED humbd(1 TO 100)
DIM SHARED humamo
DIM SHARED modi

DIM SHARED curry
DIM SHARED currm
DIM SHARED currd

DIM SHARED colstd
DIM SHARED colusr


start

cmdline

SUB cmd (a$)
IF a$ = SPACE$(LEN(a$)) THEN GOTO 2
getson a$

SELECT CASE sona$(1)
CASE "help"
  PRINT "about   - display banner"
  PRINT "help    - get help"
  PRINT "bye     - quit program"
  PRINT "who     - display list of known peoples"
  PRINT "add name birtyear birthmonth birthday"
  PRINT "        - add new human to list"
  PRINT "rm name - remove human from list"
  PRINT "clear   - clear humans list"
  PRINT "today name - show biorythm for today"
  PRINT "look name year month day"
  PRINT "        - show biorythm for given day"

  COLOR getcol(255, 0, 0)
  PRINT "physical";
  COLOR getcol(0, 255, 0)
  PRINT " emotional";
  COLOR getcol(0, 0, 255)
  PRINT " intellectual"
  COLOR getcol(255, 255, 0)
  PRINT "o-sunday"


CASE "about"
  PRINT "Biorythm calculator, by"
  PRINT "Svjatoslav Agejenko: n0@hot.ee"
  PRINT "2003.July.07"
  PRINT "current date:"; curry; currm; currd
  PRINT "type 'help' to get help"
CASE "bye"
  quit
CASE "add"
  IF humamo = 100 THEN PRINT "too mutch peoples in database": GOTO 2
  IF LEN(sona$(2)) > 12 THEN PRINT "Name too long. Use short nicknames.": GOTO 2
  FOR a = 1 TO humamo
    IF humnick$(a) = sona$(2) THEN PRINT "such name already exists": GOTO 2
  NEXT a
  humamo = humamo + 1
  humnick$(humamo) = sona$(2)
  humby(humamo) = VAL(sona$(3))
  humbm(humamo) = VAL(sona$(4))
  humbd(humamo) = VAL(sona$(5))
  modi = 1
CASE "who"
  IF humamo = 0 THEN
    PRINT "no humans in database"
  ELSE
  FOR a = 1 TO humamo
    PRINT humnick$(a) + SPACE$(15 - LEN(humnick$(a)));
    ztt = getday(curry, currm, currd) - getday(humby(a), humbm(a), humbd(a))
    getdata ztt, y1, y2, y3
    c = getcol((y1 + 100) * 1.25, (y2 + 100) * 1.25, (y3 + 100) * 1.25)
    COLOR c
    FOR b = 1 TO 5
      PRINT CHR$(219);
    NEXT b
    COLOR colstd
    PRINT humby(a); humbm(a); humbd(a)
  NEXT a
  END IF
CASE "clear"
  humamo = 0
  modi = 1
CASE "rm"
  FOR a = 1 TO humamo
    IF sona$(2) = humnick$(a) THEN
      humnick$(a) = humnick$(humamo)
      humby(a) = humby(humamo)
      humbm(a) = humbm(humamo)
      humbd(a) = humbd(humamo)
      humamo = humamo - 1
      GOTO 2
    END IF
  NEXT a
  PRINT "such human not found in list"
CASE "today"
  FOR a = 1 TO humamo
    IF sona$(2) = humnick$(a) THEN
      dispgraph getday(humby(a), humbm(a), humbd(a)), getday(curry, currm, currd)
      GOTO 2
    END IF
  NEXT a
  PRINT "such human not found in list"
CASE "look"
  FOR a = 1 TO humamo
    IF sona$(2) = humnick$(a) THEN
      dispgraph getday(humby(a), humbm(a), humbd(a)), getday(VAL(sona$(3)), VAL(sona$(4)), VAL(sona$(5)))
      GOTO 2
    END IF
  NEXT a
  PRINT "such human not found in list"
CASE ELSE
  PRINT "unknown command> " + a$
END SELECT
2
END SUB

SUB cmdline

1
COLOR colusr
LINE INPUT a$
COLOR colstd

cmd a$
GOTO 1
END SUB

SUB dispgraph (sday, dday)
FOR a = 1 TO 6
  PRINT ""
NEXT a

LINE (0, 145)-(319, 190), 1, BF
h = (145 + 190) / 2

LINE (0, h)-(319, h), getcol(0, 0, 80)

FOR x = 3 TO 319 STEP 8
NEXT x

ttime = dday - sday

clr1 = getcol(255, 0, 0)
clr2 = getcol(0, 255, 0)
clr3 = getcol(0, 0, 255)
w = getcol(255, 255, 255)

FOR x = 1 TO 319
  zt = x / 8 + ttime - 10
  IF zt = INT(zt) THEN
    IF zt + sday = dday THEN
      LINE (x, 145)-(x, 190), getcol(200, 200, 0)
    ELSE
      LINE (x, 145)-(x, 190), getcol(100, 100, 100)
    END IF
    IF (zt + sday) MOD 7 = 6 THEN CIRCLE (x, 145), 2, getcol(255, 255, 0)
  END IF
  getdata zt, y1, y2, y3
  c = getcol((y1 + 100) * 1.25, (y2 + 100) * 1.25, (y3 + 100) * 1.25)
  PSET (x, h + 1), c
  PSET (x, h - 1), c
  LINE (x, h - y1 / 5)-(x - 1, h - oy1 / 5), clr1
  LINE (x, h - y2 / 5)-(x - 1, h - oy2 / 5), clr2
  LINE (x, h - y3 / 5)-(x - 1, h - oy3 / 5), clr3
  PSET (x - 1, h), c
  oy1 = y1
  oy2 = y2
  oy3 = y3
NEXT x

END SUB

DEFLNG Z
FUNCTION getcol (r, g, b)
IF r < 0 THEN r = 0
IF g < 0 THEN g = 0
IF b < 0 THEN b = 0
IF r > 255 THEN r = 255
IF g > 255 THEN g = 255
IF b > 255 THEN b = 255
getcol = INT(r / 43) * 36 + INT(g / 43) * 6 + INT(b / 43)
END FUNCTION

DEFSNG Z
SUB getdata (zt, y1, y2, y3)
y1 = gety(zt, 23)
y2 = gety(zt, 28)
y3 = gety(zt, 33)
END SUB

DEFLNG Z
FUNCTION getday (y, m, d)
r = d
FOR a = 1600 TO y - 1
  r = r + 365
  IF a \ 4 = a / 4 THEN r = r + 1
NEXT a

FOR a = 1 TO m - 1
  r = r + mdays(y, a)
NEXT a

getday = r
END FUNCTION

SUB getson (a$)
mitus = 0

d = 1
FOR b = 1 TO LEN(a$)
c$ = RIGHT$(LEFT$(a$, b), 1)
IF c$ = " " THEN
d = 1
ELSE
IF d = 1 THEN
mitus = mitus + 1
sona$(mitus) = ""
d = 0
END IF
sona$(mitus) = sona$(mitus) + c$
END IF
NEXT b

END SUB

DEFSNG Z
FUNCTION gety (zx2, re)
zx1 = zx2
9
IF zx1 > (re * 100) THEN zx1 = zx1 - (re * 100): GOTO 9
8       
IF zx1 > (re * 10) THEN zx1 = zx1 - (re * 10): GOTO 8
7
IF zx1 >= re THEN zx1 = zx1 - re: GOTO 7

zx1 = zx1 * (100 / re)

IF zx1 MOD 100 < 50 THEN s = 100 ELSE s = -100
zx = zx1 * 2 MOD 100
IF zx < 88 THEN
  gety = SIN(zx / 52) * s
ELSE
  gety = SIN(pi / 2 + (zx - 88) / 6.7) * s
END IF
END FUNCTION

DEFLNG Z
SUB listload
OPEN "ppl.txt" FOR INPUT AS #1
6
IF EOF(1) <> 0 THEN GOTO 5
LINE INPUT #1, a$
a$ = "add " + a$
cmd a$
GOTO 6
5
CLOSE #1
END SUB

SUB listsave
OPEN "ppl.txt" FOR OUTPUT AS #1
  FOR a = 1 TO humamo
    PRINT #1, humnick$(a); humby(a); humbm(a); humbd(a)
  NEXT a
CLOSE #1
PRINT "list updated"
END SUB

FUNCTION mdays (y, m)

SELECT CASE m
CASE 1
  r = 31
CASE 2
  IF y / 4 = y \ 4 THEN r = 29 ELSE r = 28
CASE 3
  r = 31
CASE 4
  r = 30
CASE 5
  r = 31
CASE 6
  r = 30
CASE 7
  r = 31
CASE 8
  r = 31
CASE 9
  r = 30
CASE 10
  r = 31
CASE 11
  r = 30
CASE 12
  r = 31
END SELECT

mdays = r
END FUNCTION

SUB quit

IF modi <> 0 THEN
4
  PRINT "Known humans list is modified,"
  PRINT "save modifications ? (y/n)"
  a$ = INPUT$(1)
  IF a$ = "n" THEN GOTO 3
  IF a$ <> "y" THEN GOTO 4
  listsave
END IF

3
SYSTEM
END SUB

SUB setupal
c = 0
FOR r = 0 TO 5
FOR g = 0 TO 5
FOR b = 0 TO 5
OUT &H3C8, c
c = c + 1
OUT &H3C9, r * 12
OUT &H3C9, g * 12
OUT &H3C9, b * 12
NEXT b
NEXT g
NEXT r
END SUB

DEFSNG Z
SUB start
a$ = DATE$
currm = VAL(LEFT$(a$, 2))
curry = VAL(RIGHT$(a$, 4))
currd = VAL(RIGHT$(LEFT$(a$, 5), 2))
colstd = getcol(100, 150, 255)
colusr = getcol(0, 255, 0)


pi = 3.1415
humamo = 0

SCREEN 13
VIEW PRINT 1 TO 25
setupal
COLOR colstd


FOR a = 1 TO 30
  PRINT ""
NEXT a

cmd "about"

listload
modi = 0



END SUB