BIRTHDAY ou connaitre le jour de sa naissance

rem *****************************
rem * BIRTHDAY - born a day *
rem * Version 3.00 *
rem * Copyright novembre 2009 *
rem *****************************
error_french
rem ***** DECLARATION DE VARIABLES ALPHANUMERIQUES
dim aff$,annee$,an$,b$,dat$,i$,n1$,o1$
rem ***** DECLARATION DE VARIABLES NUMERIQUES
dim a,c,h,i,j,jo,k,l,l1,w,x,y
dim an,dat,fan,m1,m2
rem ***** DECLARATION DE TABLEAU
dim n$(7),m(12),o$(12),nb(12)
rem ***** DECLARATION D'ETIQUETTES
label affich,ecran,create,comb,test,ent,ent2,ent3,tablo,datas,fin,again
label pos180,pos195,pos340,pos380,pos470
rem ***** CREATION D'OBJETS SYSTEME
gosub create
rem ***** REMPLISSAGE DU TROISIEME COMBOS
gosub comb
rem ***** INITIALISATION DE L'ECRAN
gosub ecran
rem ***** ENTREE DES DATAS
gosub datas
rem ***** REMPLISSAGE DES TABLEAUX
gosub tablo
rem ***** TEST SUR OBJETS SYSTEME
gosub test
end
rem ********** Sous programmes
rem ***** INITIALISATION DE L'ECRAN
ecran:
l1 = screen_x : h = screen_y
x = (l1-400)/2 : y = (h-250)/2
left 0,x : top 0,y : width 0,400 : height 0,250
caption 0,"BIRTHDAY - Born a day - Version 3.00"
border_small 0
return
rem ***** CREATION D'OBJETS SYSTEME
create:
for i=1 to 3 : combo i : hide i : next i
for i=4 to 9 : alpha i : hide i : next i
button 10 : hide 10 : button 11 : hide 11
caption 4,"Entrez votre date de naissance :"
caption 5,"Jours" : caption 6,"Mois" : caption 7,"Années"
caption 8,"Vous êtes né le : "
caption 10,"Recommencer" : caption 11,"Terminer"
return
rem ***** REMPLISSAGE DU TROISIEME COMBOS
comb:
gosub ecran
dat$ = right$(date$,4) : dat = val (dat$)
for i=1949 to dat : i$ = str$(i) : item_add 3,i$ : next i
left 1,50 : top 1,60 : width 1,45 : height 1,25 : show 1 : inactive 1
left 2,120 : top 2,60 : width 2,100 : height 2,25 : show 2 : inactive 2
left 3,250 : top 3,60 : width 3,60 : height 3,25 : show 3
left 4,50 : top 4,20 : show 4
left 5,50 : top 5,40 : show 5
left 6,120 : top 6,40 : show 6
left 7,250 : top 7,40 : show 7
return
rem ***** TEST SUR OBJETS SYSTEME
test:
gosub ecran
on_click 1,ent3
on_click 2,ent2
on_click 3,ent
on_click 10,again
on_click 11,fin
return
rem ***** ENTREE DANS LE DEUXIEMME COMBO
ent:
gosub ecran
inactive 3 : active 2
for i=1 to 12 : item_add 2,o$(i) : next i
return
rem ***** ENTREE DANS LE PREMIER COMBO
ent2:
gosub ecran
jo = item_index(2) : an$ = item_index$(3) : an = val (an$) : fan = frac (an/4)
if jo=2 and fan=0 then m(2)=29
inactive 2 : active 1
for i=1 to m(jo) : item_add 1,i : next i
return
rem ***** DEBUT DE CALCUL DU JOUR
ent3:
gosub ecran
inactive 1
a=an : b$= item_index$(2) : c= item_index(1)
j=1 : i=6 : k=1 : l=1949 : goto pos340
pos180:
if frac(l/4)=0 then m(2)=29 else m(2)=28
pos195:
gosub ecran
if l=a and b$=o$(k) and c=j then goto affich
i=i+1 : if i>7 then i=1
j=j+1 : if j>m(k) then j=1 : k=k+1
if k>12 then k=1 : l=l+1 : goto pos180
goto pos195
pos340:
gosub ecran
if frac(l/4)=0 then i=i+2 : if i>7 then i=i-7
if frac(l/4)<>0 then i=i+1 : if i>7 then i=1
l=l+1
if l=a then goto pos380
goto pos340
pos380:
gosub ecran
if frac(l/4)=0 then nb(3)=1
if frac(l/4)<>0 then nb(3)=0
w=1
pos470:
gosub ecran
i=i+nb(w) : if i>7 then i=i-7
if b$=o$(k) then goto pos195
w=w+1
k=k+1
goto pos470
return
rem ***** AFFICHAGE DU RESULTAT
affich:
gosub ecran
aff$= n$(i)+" "+str$(j)+" "+o$(k)+" "+str$(l)
left 8,50 : top 8,120
left 9,50 : top 9,140 : caption 9,aff$
left 10,200 : top 10,160 : width 10,80 : height 10,30
left 11,300 : top 11,160 : width 11,80 : height 11,30
show 8 : show 9 : show 10 : show 11
return
rem ***** REMPLISSAGE DES TABLEAUX
tablo:
for i=1 to 7 : read n1$ : n$(i)=n1$ : next i
for i=1 to 12 : read o1$ : o$(i)=o1$ : next i
for i=1 to 12 : read m1 : m(i)=m1 : next i
for i=1 to 12 : read m2 : nb(i)=m2 : next i
return
rem ***** ENTREE DES DATAS
datas:
data LUNDI,MARDI,MERCREDI,JEUDI,VENDREDI,SAMEDI,DIMANCHE
data JANVIER,FEVRIER,MARS,AVRIL,MAI,JUIN,JUILLET,AOUT,SEPTEMBRE,OCTOBRE,NOVEMBRE,DECEMBRE
data 31,28,31,30,31,30,31,31,30,31,30,31
data 0,3,0,3,2,3,2,3,3,2,3,2
return
rem ***** REINITIALISATION DU PROGRAMME
again:
gosub ecran
for i=1 to 11 : hide i : next i
for i=1 to 3 : clear i : next i
active 3
gosub comb
return
rem ***** Fin du programme
fin:
terminate

Label JourSem, Retsub, Bissex
Dim Annee, Mois, Jour, Jsem, bisex
Dim y, Result, DateSerial, tmp
Dim j$(7)
j$(1) = "Dimanche": j$(2) = "Lundi": j$(3) = "Mardi": j$(4) = "Mercredi"
j$(5) = "Jeudi": j$(6) = "Vendredi": j$(7) = "Samedi"

Annee = 2009
Mois = 11
Jour = 13

GOSUB JourSem
PRINT j$(Jsem) + " " + str$(Jour) +"/"+str$(Mois)+"/"+str$(Annee)
stop
TERMINATE

JourSem:
rem *** Annee, Mois, Jour, résultat dans Jsem
rem *** Jour de la semaine (1= Dimanche à 7= Samedi, 0 si date invalide)
Jsem = 0: y = Annee
IF y < 179 THEN y = y + 1900
IF Mois<1 OR Mois>12 OR Jour<1 OR Jour>31 OR y<1753 OR y>2078 THEN GOTO Retsub
SELECT Mois
    CASE 1: Result = 0
    CASE 2: Result = 31
    CASE 3: Result = 59
    CASE 4: Result = 90
    CASE 5: Result = 120
    CASE 6: Result = 151
    CASE 7: Result = 181
    CASE 8: Result = 212
    CASE 9: Result = 243
    CASE 10: Result = 273
    CASE 11: Result = 304
    CASE 12: Result = 334
END_SELECT
Result = Result + Jour - 1
GOSUB Bissex
IF bisex = 1 THEN IF Mois > 2 THEN Result = Result + 1
REPEAT
    y = y - 1: GOSUB Bissex
    IF bisex = 1 THEN Result = Result + 1
    Result = Result + 365
UNTIL y <= 1753
DateSerial = Result - 53688
tmp = 7* FRAC(DateSerial/7) : rem *** reste entier de la division
if tmp = 0 then tmp = 7
IF tmp < 0 THEN tmp = tmp + 7
Jsem = INT(tmp+.1): Rem *** à cause des arrondis (6.9999999999...)
Retsub:
RETURN

Bissex:
bisex = 0
IF (FRAC(y/4) = 0 and FRAC(y/100) > 0) or FRAC(y/400) = 0
    bisex = 1: Rem *** l'année y est bissextile
END_IF
RETURN

dim i,NomFichier$:label save

top 0,150:left 0,290:Width 0,300:height 0,200
caption 0,"Date de Naissance"

alpha 1
left 1,10
top 1,10
font_size 1,10
caption 1,"Entrer Votre Date De Naissance Et Votre Age :"

combo 2
left 2,15
width 2,80
top 2,60
text 2,"1900"
for i=1900 to 2099
  item_add 2,i
next i

combo 3
left 3,105
width 3,90
top 3,60
text 3,"Janvier"
item_add 3,"Janvier":item_add 3,"Février":item_add 3,"Mars"
item_add 3,"Avril":item_add 3,"Mai":item_add 3,"Juin"
item_add 3,"Juillet":item_add 3,"Août":item_add 3,"Septembre"
item_add 3,"Octobre":item_add 3,"Novembre":item_add 3,"Décembre"

combo 4
top 4,60
width 4,77
left 4,205
text 4,"1"
for i=1 to 31
  item_add 4,i
next i

alpha 5
top 5,100
left 5,90
caption 5,"Age :"

spin 6
left 6,125
top 6,98
width 6,60

button 7
top 7,130
left 7,15
width 7,262
on_click 7,save
caption 7,"Enregistrer"

memo 9:hide 9

end

save:
save_dialog 8
filter 8,"TXT/TEXTE - Fichiers Texte|*.txt"
NomFichier$=file_name$(8)
delete 8
item_add 9,"Date De Naissance : Année :  "+text$(2)
item_add 9,"Date De Naissance : Mois :  "+text$(3)
item_add 9,"Date De Naissance : Jour :  "+text$(4)
item_add 9,"Age : Age :  "+text$(6)
file_save 9,NomFichier$+".txt"
return