La fin du monde n'aura pas lieu

rem ' ***** Fabricateur de calendriers perpétuels ***** Fabric-Calendrier-perpet
dim ex , ie, j1 , j2 , j3 , m1 , m2 , m3 , tt , c$ , e$ , o$ , t$
dim a , b , c , d , e , f , g , h , i , j , k , m , n , p , q , r
dim  s , t , u , v , x , y , w , z , j$(7) , m$(12)
data "Dim." , "Lun." , "Mar." , "Mer." , "Jeu.." , "Ven." , "Sam"
data "JAN" , "FEV" , "MAR" , "AVR" , "MAI" , "JUIN" , "JUIL"
data "AOU" , "SEP" , "OCT" , "NOV" , "DEC"
label calcul , fin , ecran , choix , excel , aide , egal , fini , JJN4
c$="Auteur de ce programme :  jjn4"

dim findumonde$:findumonde$="O"

for i=0 to 6
 read j$(i)
next i
for i=1 to 12
 read m$(i)
next i

width 0,450 : height 0,250 : caption 0,"Fabricateur de calendriers"

alpha 1:left 1,60 : top 1,40:font_bold 1 :font_size 1,14
caption 1,"CALENDRIER PERPÉTUEL"

alpha 2:left 2,100 : top 2,85
caption 2,"Quelle année"

edit 3:left 3,180 : top 3,80 : width 3,60 : height 3,21
on_change 3,egal:set_focus 3

button 4:left 4,250 : top 4,125 : width 4,60 : height 4,21
caption 4,"MAYA"
on_click 4,ecran


alpha 5:left 5,10 : top 5,170
caption 5,c$

spin 7:left 7,160 : top 7,2 : width 7,53
on_change 7,choix:hide 7

button 9:left 9,287 : top 9,2 : width 9,60 : height 9,21
caption 9,"Imprimer"
on_click 9,excel:hide 9

button 10:left 10,253 : top 10,2 : width 10,40 : height 10,21
caption 10,"Aide"
on_click 10,aide:hide 10

form 11:left 11,200 : top 11,100 : width 11,450 : height 11,405
caption 11,"Aide au fabricateur de calendrier perpétuel par JJN4 et rectifié par JEAN CLAUDE":hide 11

alpha 12:parent 12,11:left 12,10 : top 12,8
caption 12,a$

button 13:left 13,340 : top 13,125 : width 13,60 : height 13,21
caption 13,"JJN4 et JC"
on_click 13,JJN4

end
' ==============================================================================
JJN4:
findumonde$="NIET":gosub ecran
return

egal:
if text$(3)<>"" then position 7,text$(3)
return

ecran:
if findumonde$="O" then inactive 3:inactive 4:inactive 7:inactive 9:inactive 10
caption 4,"Calculer"
caption 5,"ATTENDEZ" : wait 1
if ie=0
 width 0,1200 : height 0,650
 left 2,20 : top 2,4
 left 3,95 : top 3,2
 tt=0 : if text$(3)<>"" then tt=val(text$(3))
 show 7 : position 7,tt
 left 1,500 : top 1,1
 caption 1,"CALENDRIER  "+text$(3)
 left 5,850 : top 5,4
 left 4,220 : top 4,2
 hide 13
 picture 8 : left 8,0 : top 8,25 : width 8,1011 : height 8,578
 color 8,192,192,192 : show 9 : left 10,353 : show 10
 for i=9 to 20
  for j=1 to 32
  alpha (i-8)*32+j :              alpha (i-8)*32+j+400
  left (i-8)*32+j,(i-9)*84+2 :    left (i-8)*32+j+400,(i-9)*84+2
  top (i-8)*32+j,j*18+8 :        top (i-8)*32+j+400,j*18+8
  width (i-8)*32+j,83 :          width (i-8)*32+j+400,83
  color (i-8)*32+j,255,255,255 :  color (i-8)*32+j+400,255,255,255
  next j
  color (i-8)*32+1,180,255,255
 next i
else
 for i=9 to 20
  for j=1 to 32
  caption (i-8)*32+j+400,""
  color (i-8)*32+j,255,255,255
  color (i-8)*32+j+400,255,255,255
  next j
  color (i-8)*32+1,180,255,255
 next i
 caption 1,"CALENDRIER  "+text$(3)
end_if
ie=1
gosub calcul
return

choix:
text 3,position(7)
return

excel:
message "En passant à EXCEL, vous fermez le calendrier"
ex=1 : gosub calcul
return

aide:
execute "Fabric-Cal-Aide.exe"
return

calcul:
t$=text$(3) : if t$="" then return
if val(t$)<1583 or val(t$)>4581 then beep : caption 5,"Non, pas possible (1583 à 4581)" : return
tt=val(t$)
' Calcul du lundi de Pâques - Algorithme de Oudin
g=tt-int(tt/19)*19
w=int(tt/100)
d=int(w/4)
e=int((8*w+13)/25)
h=19*g+w-d-e+15-int((19*g+w-d-e+15)/30)*30
k=int(h/28)
u=int(29/(h+1))
q=int((21-g)/11)
v=(k*u*q-1)*k+h
z=int(tt/4)+tt
n=z+v+2+d-w
f=n-int(n/7)*7
r=28+v-f
if h=29 and r=50 then r=57
if h=28 and g>10 and r=49 then r=56
if r>30
 j1=r-30 : m1=4
else
 j1=r+1 : m1=3
end_if
' Calcul du jeudi de l'Ascension
y=r+39
if y>92
 j3=y-92 : m3=6
else
 j3=y-61 : m3=5
end_if
' Calcul du lundi de Pentecôte
x=r+50
if x>92
 j2=x-92 : m2=6
else
 j2=x-61 : m2=5
end_if
' Calcul du jour de la semaine et affichage
c=val(left$(t$,2))
a=val(right$(t$,2))
if ex=1 then excel_start : excel_file_new 1
for m=1 to 12
 for j=1 to 31
  select m
  case 1 : t=0
  case 2 : t=3
  case 3 : t=3
  case 4 : t=6
  case 5 : t=1
  case 6 : t=4
  case 7 : t=6
  case 8 : t=2
  case 9 : t=5
  case 10 : t=0
  case 11 : t=3
  case 12 : t=5
  end_select
  if a=0 and m<3
  p=(20-c)*2+int((c-1)/4)-5
  else
  p=(19-c)*2+int(c/4)-4
  end_if
  b=int(a/4)
  if a/4=int(a/4) and m<3 then b=b-1
  s=(j+t+a+b+p)-7*int((j+t+a+b+p)/7) : s=s-int(s/7)*7
  if j=31 and (m=2 or m=4 or m=6 or m=9 or m=11) then goto fin
  if (m=2 and j>29) or (m=2 and a/4<>int(a/4) and j>28) then goto fin
  if a=0 and c/4<>int(c/4) and m=2 and j=29 then goto fin
  e$="" : if s=0 then e$="***"
  if j=1 and m=5 and tt>1946 then e$="***"
  if j=8 and m=5 and tt>1952 and tt<1960 then e$="***"
  if j=8 and m=5 and tt>1981 then e$="***"
  if j=14 and m=7 and tt>1879 then e$="***"
  if (j=15 and m=8) or (j=1 and m=11) then e$="***"
  if j=11 and m=11 and tt>1921 then e$="***"
  if j=21 and m=12 and tt=2012 then e$=" Fin du monde annulée par JJN4 et JC ":j$(s)="fin."
  if (j=25 and m=12) or (j=1 and m=1) then e$="***"
  if (j=j1 and m=m1) or (j=j2 and m=m2) or (j=j3 and m=m3) then e$="***"
  o$="" : if j<10 then o$="0"
  if j$(s)="fin."
    j$(s)="Ven.."
    color m*32+j+1,0,0,0 : color m*32+j+401,255,200,200
  if findumonde$="O" then j$(s)="fin." :wait 6000:terminate
  end_if
  if ex=0 then caption m*32+j+401,j$(s)+"."+o$+str$(j)+e$
  if e$="***" and ex=0
  if j$(s)="Dim."
    color m*32+j+1,255,255,0 : color m*32+j+401,255,255,0
  else
    color m*32+j+1,255,204,153 : color m*32+j+401,255,204,153
  end_if
  end_if
  if ex=1 then excel_write chr$(64+m*2-1)+str$(j+2),j$(s)+"."+o$+str$(j)+e$
fin:
 next j
 if ex=0
  caption m*32+401," "+m$(m)+".."+t$ : color m*32+401,180,255,255
  font_size m*32+401,10 : font_bold m*32+401
 end_if
 if ex=1 then excel_write chr$(64+m*2-1)+"2",m$(m)+".."+t$
next m
for j=1 to 19 step 6
 if ex=1 then excel_write chr$(64+j)+"1","CALENDRIER "+t$
next j
caption 5,c$
if ex=1 then goto fini
ex=0
return

fini:
terminate