' **************************************
' * JOUR DE NAISSANCE ET ANNIVERSAIRES *       J!NAISS.BAS
' **************************************
' AUTEUR DU PROGRAMME: MICHEL
' DATES: 13/10/2006
    OPTION BASE 1: DEFSTR A-Z
    SCREEN 12: WINDOW SCREEN (1, 1)-(640, 480): CLS
   
    Cfd% = 0               ' COUL DE FOND ECRAN
    Ccv% = 9               ' COUL CADRE VIDE
    Cct% = 10: Cte% = 15   ' COUL CADRE/TITRE
    Cdd% = 11              ' COUL DESIGNATIONS DONNEES
    Cdav% = 13             ' COUL DONNEES AVT SAISIE
    Cdas% = 14             ' COUL DONNEES … SAISIR
    Cds% = 15              ' COUL DONNEES APRES SAISIE
   
    DIM Nom.du.Jour(7) AS STRING * 8 ' lundi, mardi, etc...
    DIM Jour.Mois%(12)               ' Nombre de Jours par mois
    DIM Nb.J.An%(1900 TO 2200)       ' Nombre de Jours par AN
    DIM J.Deb.An%(1900 TO 2200)      ' Jour de d‚but ann‚e (1 pour lundi,
                                     ' 2 pour mardi, 3 pour mercredi, etc...)
    DATA "LUNDI","MARDI","MERCREDI", "JEUDI", "VENDREDI","SAMEDI","DIMANCHE"
    FOR I% = 1 TO 7: READ Nom.du.Jour(I%): NEXT I%
    DATA 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31
    FOR I% = 1 TO 12: READ Jour.Mois%(I%): NEXT I%
    ' **** Le mois '2' sera mis … 29 pour les ann‚es bissextiles
    Nb.J.An%(1900) = 365: Nb.J.An%(2000) = 366
    Nb.J.An%(2100) = 365: Nb.J.An%(2200) = 365
    ' **** Pour ‚liminer de suite les ann‚es NN00 (Bissextiles ou non)
        FOR I% = 1900 TO 2200
            IF I% MOD 100 = 0 GOTO NAIXT ' Elimination des NN00
            IF I% MOD 4 = 0 THEN
                Nb.J.An%(I%) = 366
            ELSE
                Nb.J.An%(I%) = 365
            END IF
NAIXT:  NEXT I%
    J.Deb.An%(1900) = 1: Num.J% = 1  ' **** LA BASE DE TOUT ****
                                     ' **** LE 1ER JANVIER 1900 EST UN LUNDI
    ' **** Quel jour tombe le premier janvier ?
    FOR I% = 1901 TO 2200
        ' **** Si l'ann‚e pr‚c‚dente est bissextile, alors ...
        IF Nb.J.An%(I% - 1) = 366 THEN Num.J% = Num.J% + 2
        ' **** Si elle ne l'est pas ...
        IF Nb.J.An%(I% - 1) = 365 THEN Num.J% = Num.J% + 1
        IF Num.J% > 7 THEN Num.J% = Num.J% - 7
        J.Deb.An%(I%) = Num.J%
    NEXT I%
    ' **** Pr‚sentation
    Titre = " ANNIVERSAIRES ": L% = 3: GOSUB GS08.GAUCHE
    Titre = " INDIQUEZ la DATE de NAISSANCE (JJMMAAAA) :           "
    L% = 3: GOSUB GS08.DROIT
    K% = 11: GOSUB GS01.CADRE
    FOR L% = 5 TO 28: FOR C% = 5 TO 77 STEP 18
        LOCATE L%, C%: COLOR 10: PRINT "º"
    NEXT C%, L%
    LINE (35, 60)-(615, 61), 10, BF: LINE (38, 63)-(612, 64), 10, BF
A00.DATE: ' **** Saisie date de naissance
    L% = 3: C% = 67: S.Pr = "JJMMAAAA": Nbc% = 8: GOSUB GS07.ALPHA
    Jn% = VAL(LEFT$(S, 2)): Mn% = VAL(MID$(S, 3, 2)): An% = VAL(RIGHT$(S, 4))
    ' **** Est elle possible ?
    IF An% < 1900 OR An% > 2100 THEN
        M = " Ann‚e < 1900 ou sup‚rieure … 2100 (PRESSEZ 'ESPACE')"
        GOSUB GS05.ERREUR: GOTO A00.DATE
    END IF
    IF Mn% < 1 OR Mn% > 12 THEN
        M = " !!! MOIS INVALIDE !!! (PRESSEZ 'ESPACE')"
        GOSUB GS05.ERREUR: GOTO A00.DATE
    END IF
    IF Jn% < 1 OR Jn% > Jour.Mois%(Mn%) THEN
        M = " !!! JOUR INVALIDE !!! (PRESSEZ 'ESPACE')"
        GOSUB GS05.ERREUR: GOTO A00.DATE
    END IF
    
    FOR N% = 0 TO 95
        IF N% < 24 THEN L% = N% + 5: C% = 7
        IF N% > 23 AND N% < 48 THEN L% = N% - 19: C% = 25
        IF N% > 47 AND N% < 72 THEN L% = N% - 43: C% = 43
        IF N% > 71 THEN L% = N% - 67: C% = 61
        ' **** Combien de jour en f‚vrier ?
        IF An% = 1900 OR An% = 2100 THEN ' **** Non Divisibles par 400
            Jour.Mois%(2) = 28: GOTO A02.SUITE
        END IF
        IF An% MOD 4 = 0 THEN Jour.Mois%(2) = 29 ELSE Jour.Mois%(2) = 28
A02.SUITE:
        LOCATE L%, C%: COLOR 10: PRINT USING "##"; N%
        LOCATE L%, C% + 3: COLOR 11: PRINT USING "####"; An%
        Nb.J.Depuis.1.J% = 0
        FOR M% = 1 TO Mn% - 1 ' **** Mois complets
            Nb.J.Depuis.1.J% = Nb.J.Depuis.1.J% + Jour.Mois%(M%)
        NEXT M%
        Nb.J.Depuis.1.J% = Nb.J.Depuis.1.J% + Jn%
        Numero.Jour.Total% = J.Deb.An%(An%) + Nb.J.Depuis.1.J% - 1
        Nb.Semaines% = INT(Numero.Jour.Total% / 7)
        Num.Jour.Semaine% = Numero.Jour.Total% - Nb.Semaines% * 7
        IF Num.Jour.Semaine% = 0 THEN Num.Jour.Semaine% = 7
        LOCATE L%, C% + 8: COLOR 14
        PRINT Nom.du.Jour(Num.Jour.Semaine%)
        An% = An% + 1
    NEXT N%
    END
GS01.CADRE: DIM G&(73)
    FOR I% = 1 TO 16: LINE (I%, I%)-(I%, 232), K%, , 32752: NEXT I%
    Y% = 234
    FOR X% = 1 TO 16: Y% = Y% - 1: LINE (X%, Y%)-(X%, 464), K%, , 4095: NEXT X%
    FOR I% = 1 TO 16: LINE (I%, I%)-(320, I%), K%, , 32752: NEXT I%
    X% = 322
    FOR Y% = 1 TO 16: X% = X% - 1: LINE (X%, Y%)-(640, Y%), K%, , 4095: NEXT Y%
    Y% = 465
    FOR X% = 1 TO 16: Y% = Y% - 1: LINE (X%, Y%)-(320, Y%), K%, , 32752: NEXT X%
    X% = 322: Y% = 465
    FOR I% = 1 TO 16: X% = X% - 1: Y% = Y% - 1
        LINE (X%, Y%)-(640, Y%), K%, , 4095
    NEXT I%
    X% = 641
    FOR Y% = 1 TO 16: X% = X% - 1: LINE (X%, Y%)-(X%, 232), K%, , 32752: NEXT Y%
    X% = 641: Y% = 234
    FOR I% = 1 TO 16: X% = X% - 1: Y% = Y% - 1
        LINE (X%, Y%)-(X%, 464), K%, , 4095
    NEXT I%
    K% = 12
    LINE (1, 1)-(24, 24), K%, B: LINE (1, 1)-(24, 24), K%
    LINE (1, 24)-(24, 1), K%: PAINT (6, 12), K%, K%
    PAINT (12, 6), K%, K%: PAINT (18, 12), K% - 8, K%
    PAINT (12, 18), K% - 8, K%: LINE (1, 1)-(12, 12), 15
    GET (1, 1)-(24, 24), G&: PUT (1, 220), G&, PSET
    PUT (1, 441), G&, PSET: PUT (308, 1), G&, PSET
    PUT (308, 441), G&, PSET: PUT (617, 1), G&, PSET
    PUT (617, 220), G&, PSET: PUT (617, 441), G&, PSET
    RETURN
 
GS02.ESPACE: M = " * Appuyez sur la TOUCHE ESPACE pour POURSUIVRE * ": GOTO GS05.ERREUR
GS03.BIP: FOR B% = 1 TO 2: PLAY "O2 L32 CC+DD+EFF+": NEXT B%: RETURN
GS04.SIRENE: FOR Z% = 500 TO 100 STEP -5: SOUND Z%, Z% / 5000: NEXT Z%: RETURN
' ***** AFFICHAGE MESSAGE en Ligne 30
GS05.ERREUR: Col.Er% = 41 - LEN(M) / 2: GOSUB GS04.SIRENE
    LOCATE 30, Col.Er%: COLOR 13: PRINT M; : GOSUB GS06.ATTENTE
    LOCATE 30, 1: PRINT SPACE$(80); : RETURN
GS06.ATTENTE: K = INKEY$: IF K = "" GOTO GS06.ATTENTE
    IF K = CHR$(27) THEN COLOR 15: END
    IF K <> " " GOTO GS06.ATTENTE
    RETURN
 
GS07.ALPHA: ' ***** SAISIE ALPHANUMERIQUE
    Lsp% = LEN(S.Pr): IF Lsp% < Nbc% THEN S.Pr = S.Pr + SPACE$(Nbc% - Lsp%)
    P% = 0: S = S.Pr
    Xhg% = (C% - 1) * 8 - 1: Yhg% = (L% - 1) * 16 - 1
    Xbd% = Xhg% + Nbc% * 8 + 2: Ybd% = Yhg% + 18
    LINE (Xhg%, Yhg%)-(Xbd%, Ybd%), 12, B
GS07A: COLOR 15: LOCATE L%, C%: PRINT S
    COLOR 12: LOCATE L%, C% + P%: PRINT MID$(S, P% + 1, 1);
    IF MID$(S, P% + 1, 1) = " " THEN LOCATE L%, C% + P%: PRINT CHR$(14);
GS07B: ' ***** Clignottement
    SELECT CASE INT(TIMER * 10) MOD 4
        CASE 0: LINE (Xhg%, Yhg%)-(Xbd%, Ybd%), 12, B, &HF0F0
        CASE 1: LINE (Xhg%, Yhg%)-(Xbd%, Ybd%), 13, B, &H7878
        CASE 2: LINE (Xhg%, Yhg%)-(Xbd%, Ybd%), 14, B, &H3636
        CASE 3: LINE (Xhg%, Yhg%)-(Xbd%, Ybd%), 15, B, &HF0F0
    END SELECT
    K = INKEY$: IF K = "" GOTO GS07B
    SELECT CASE K
        CASE CHR$(3), CHR$(27):
            CLS : COLOR 15: END'CTRL + C ou ECHAP
        CASE CHR$(0) + "K" '… Gauche
            IF P% = 0 THEN GOSUB GS04.SIRENE: GOTO GS07B
            P% = P% - 1: GOTO GS07A
        CASE CHR$(0) + "M" '… Droite
            IF P% = Nbc% THEN GOSUB GS04.SIRENE: GOTO GS07B
            P% = P% + 1: GOTO GS07A
        CASE CHR$(13) 'Entr‚e
            IF P% = 0 THEN S = S.Pr: GOTO GS07D ELSE GOTO GS07C
        CASE CHR$(0) + "R" ' Insertion case blanche
            IF RIGHT$(S, 1) <> " " THEN GOSUB GS04.SIRENE
            S = LEFT$(S, P%) + " " + RIGHT$(S, Nbc% - P%)
            S = LEFT$(S, Nbc%): GOTO GS07A
        CASE CHR$(0) + "S" ' Suppression
            S = LEFT$(S, P%) + RIGHT$(S, Nbc% - P% - 1) + " ": GOTO GS07A
        CASE CHR$(0) + "G" ' Retour au D‚but
            P% = 0: GOTO GS07A
        CASE CHR$(0) + "O" ' … la fin
            P% = LEN(RTRIM$(S)): GOTO GS07A
        CASE CHR$(8) ' Effacement caractŠre pr‚c‚dent
            IF P% = 0 THEN GOSUB GS04.SIRENE: GOTO GS07B
            IF P% = 1 THEN
                S = RIGHT$(S, Nbc% - 1) + " "
            ELSE
                S = LEFT$(S, P% - 1) + RIGHT$(S, Nbc% - P%) + " "
            END IF
            P% = P% - 1: GOTO GS07A
        CASE CHR$(9), CHR$(29)
            GOSUB GS03.BIP: GOTO GS07A
        CASE ELSE
            P% = P% + 1
            IF P% > Nbc% THEN GOSUB GS04.SIRENE: P% = Nbc%: GOTO GS07A
            MID$(S, P%, 1) = K: GOTO GS07A
    END SELECT
GS07C: IF P% = Nbc% GOTO GS07D
    Pk% = INSTR(S, "æ"): IF Pk% = 0 THEN Pk% = INSTR(S, "*")
    IF Pk% > 0 THEN S = LEFT$(S, Pk% - 1)
    Ls% = LEN(S): IF Ls% < Nbc% THEN S = S + SPACE$(Nbc% - Ls%)
GS07D: LOCATE L%, C%: COLOR Cds%: PRINT S
    SAISIE = S: LINE (Xhg%, Yhg%)-(Xbd%, Ybd%), Cfd%, B
    RETURN
 
' ***** TITRE ENTOURE d'un CADRE *****
GS08.GAUCHE: L% = L% - 1: C% = 4: GOTO GS08.TITRE
GS08.CENTRE: L% = L% - 1: C% = 39 - LEN(Titre) / 2: GOTO GS08.TITRE
GS08.DROIT: L% = L% - 1: C% = 76 - LEN(Titre)
GS08.TITRE: Lg% = LEN(Titre): COLOR Cct%
    LOCATE L%, C%: PRINT "É"; STRING$((Lg%), "Í"); "»"
    LOCATE L% + 1, C%: PRINT "º": LOCATE L% + 1, C% + Lg% + 1: PRINT "º"
    LOCATE L% + 2, C%: PRINT "È"; STRING$((Lg%), "Í"); "¼"
    LOCATE L% + 1, C% + 1: COLOR Cte%: PRINT Titre; : RETURN
GS08.REMPLI: Cr% = 2
    Xg% = C% * 8: Xd% = (C% + Lg%) * 8 + 1
    Yh% = (L%) * 16 - 6: Yb% = Yh% + 26
    FOR X% = Xg% TO Xd%: FOR Y% = Yh% TO Yb%
        IF POINT(X%, Y%) = 0 THEN PSET (X%, Y%), Cr%
    NEXT Y%, X%
    RETURN
GS08.ENCADRE: Xchg% = (Cc% - 1) * 8 + 1: Ychg% = (Lc% - 1) * 16 + 1
    Xcbd% = (Cc% + Nc% - 1) * 8: Ycbd% = Ychg% + 14: Kc% = 15
    LINE (Xchg%, Ychg%)-(Xcbd%, Ycbd%), Kc%, B, &H3333
    LINE (Xchg%, Ychg%)-(Xcbd%, Ycbd%), 12, B, &HCCCC
    RETURN
 
' ***** AFFICHAGE CADRE VIDE *****
GS09.CV: COLOR Ccv%
    LOCATE Lchg%, Cchg%: PRINT "É"; STRING$((Ccbd% - Cchg% - 1), "Í"); "»"
    LOCATE Lcbd%, Cchg%: PRINT "È"; STRING$((Ccbd% - Cchg% - 1), "Í"); "¼"
    FOR L% = Lchg% + 1 TO Lcbd% - 1
        LOCATE L%, Cchg%: PRINT "º": LOCATE L%, Ccbd%: PRINT "º": NEXT L%
    RETURN