Les programmes de papydall

rem =================================================================
rem              Cercle tournant
rem =================================================================
const r1 = 150 : ' modifier ces ...
const r2 = 150 : ' ... constantes
const p  = 8   : ' essayer 4,5,6,7,8,9,10
const deg2rad = pi/180
dim a,b,n,m,x,y

mode 3,"Cercle tournant",700,700 : origin 350,350
for n = 0 to 360 step p
    x = cos(n*deg2rad) * r1
    y = sin(n*deg2rad) * r1
    for m = 0 to 360
        a = cos(m*deg2rad) * r2
        b = sin(m*deg2rad) * r2
        plot a + x, b + y
    next m
    sleep 50 : ' temporisation pour suivre le tracé à modifier
next n

while inkey$() = "" : wend
end
rem ===================================================================

rem ================================================================
rem                 Attracteur de Lorentz
rem ================================================================
const s = 10
const p = 28
const b = 8/3
const zoom = 6
const dt = 0.002
dim dx,dy,dz,x,y,z,t
x = 10 : y = 0 : z = 10
mode 3,"Attracteur de Lorentz : <ESC> pour sortir ...",900,300
while inkey$() <> "ESCAPE"
    dx = s*(y-x) : dy = x*(p-z)-y : dz = x*y-b*z
    x = x+dx*dt : y = y+dy*dt : z = z+dz*dt
    plot 160-zoom*y,zoom*z : plot 470+zoom*x,zoom*z : plot 750+zoom*x,150+zoom*y
    for t = 1 to 30000 : next : ' temporisation
wend
rem ==================================================================

rem =================================================================
rem         Du n importe quoi
rem =================================================================

dim a,r ,xp,yp,i

mode 3,"Du n importe quoi !!!" ,800,600 : origin 400,300
 while inkey$ = ""
    randomize timer
    a = a+.0123456789 : r = r+.0123456789  : xp = 2*r*COS(a) : yp = r*SIN(a)
    if r > 100 then r = 0
    pen rgb(255,255*rnd(),150) : rectangle xp-40,yp-40,40,40
    xp = r*COS(a+.079*9) : yp = r*SIN(a+.079*9)
    pen rgb(255*rnd(),0,155) : arc xp, yp,50 : pen rgb(255,255*rnd(),255) : arc xp+yp,xp-yp,40
    pen rgb(150*rnd(),150,150*rnd()) : arc yp,xp-yp/1.25,60
    pen rgb(255*rnd(),255*rnd(),255*rnd()) : rectangle xp-yp,yp,20,15
    pen rgb(255,255*rnd(),255*rnd()) : arc yp,xp-yp,60 : pen rgb(255*rnd(),255*rnd(),255*rnd())
    arc xp+xp/3+yp/4,xp-yp,5
 wend
rem =====================================================================

rem ===================================================================
rem          Sun rise
rem ===================================================================
dim c,xs,ys,x,y
c = 7
xs = 750
ys = 520
mode 3,"Sun rise",xs,ys
for y = ys to 0 step -1
   for x = 0 to xs
      c = c*1.00005
      pen rgb((c\256\256) mod 256, (c\256) mod 256, c mod 256)
      plot x,ys-y
   next x  
next y
while inkey$() = "" : wend
rem =====================================================================

rem ============================================================================
rem                  Landscape_Generator.bas
rem                  Générateur de  paysages
rem                      Par Papydall
rem Adaptation de mon programme du même nom en Panoramic
rem http://panoramic.1fr1.net/t4370-generateur-de-paysages?highlight=g%C3%A9n%C3%A9rateur
rem ============================================================================
rem Pour des chaînes de montagnes normales, utiliser startval1 = 256 et startval2 = 2
rem Pour des paysages étranges utiliser startval1 = 500 et startval2 = 6
rem Jouez avec ces paramètres pour essayer des dunes ou des paysages marins
rem ============================================================================

const w = 1400 : ' Adapter ces valeurs ...
const h = 700  : ' ... selon votre écran

dim range(4096)
dim lowr      : lowr = 10
dim col       : col = 240 : ' essayer 200 ou autre valeur
dim delta_col : delta_col = 48
dim rand      
dim lowmount  : lowmount = 0
dim startval1 : startval1 = 300 : ' 500
dim startval2 : startval2 = 3   : ' 6
dim newval1, newval2, amplitude, frequence, oldx, oldrange
dim lacr, lacg, lacb, decrease, a, seed, k,sw

randomize timer
rand = rnd
if rand < .5 then sw = 0  else  sw = 1

mode 3,"Landscape Gererator by Papydall", w, h  
origin 0,700
paper rgb(150,200,255) : cls

Draw_Mountain

while inkey$() = "" : wend
rem ===================================================================
rem ============================================================================
' Dessiner 6 chaînes de montagnes
SUB Draw_Mountain()
    dim n, inc, i
    for n = 1 to 6
        newval1 = startval1 : newval2 = startval2
' Chaque chaîne de montagnes est produite par 6 fonctions "Bruit de Perlin"
' avec diminution de l'amplitude et croissance de la fréquence
      for inc = 1 to 6
          newval1 = newval1/2 : newval2 = newval2*2 : k = 0 : seed = rnd(1)
          amplitude = newval1 : frequence = newval2 : oldx = 0 : Perlin
      next inc
' Couleur
      select n
           case 1 : pen rgb(255,255,255)
           case 2 : pen rgb(200,200,200)
           case 3 : pen rgb(150,150,150)
           case 4 : pen rgb(100,120,100)
           case 5 : pen rgb(50,100,50)
           case 6 : pen rgb(0,50,0)
      end_select

' Dessiner la chaîne de montagnes
      oldrange = range(0)
      for i = 0 to w-1
          move i-1,-(oldrange+lowmount) : draw i,-(range(i)+lowmount)
          move i-1,-(oldrange+lowmount) : draw i-1,-h
          oldrange = range(i)
      next i
      lowmount = lowmount + lowr : lowr = lowr + 25
' Pour la chaîne suivante
      for i = 0 to w-1 : range(i) = 0 : next i
      col = col - delta_col
sleep 100
    next n

' Dessinez un lac brumeux
    lacr = col + delta_col : lacg = col + delta_col : lacb = 255
    decrease = (lacb-(col + delta_col))/100
    for i = 1 to 100
        pen rgb(lacr,lacg,lacb) : move 0,-(h-i) : draw w,-(h-i)
        lacb = lacb - decrease
    next i
' Dessiner une rangée d'arbres
   Tree_Range
END_SUB
rem ============================================================================
' Fonction Bruit de Perlin
SUB Perlin()
    dim zz,x,pointa,pointb, f,ft,interp
    MyRnd : pointb = a
    for zz= 1 to frequence
        pointa = pointb : MyRnd() : pointb = a
        for x = 0 to 1 step (1/(w/frequence))
            if sw = 1 then
              ft = x * pi : f  = (1 - cos(ft)) * .5
              interp =  pointa*(1-f) + pointb*f
            else
              interp = pointa*(1-x) + pointb*x
            end_if
            range(k) = range(k)+(interp*amplitude) : k = k + 1
        next x
        oldx = oldx + (w/frequence)
    next zz
END_SUB
rem ============================================================================
' Rangée d'arbres
' Deux fonctions "Perlin noise"
SUB Tree_Range()
    dim inc,i,uppery,colg
    colg = 255 : lowr = 380
    startval1 = 50 + int(rnd()*50) : startval2 = 128 + int(rnd()*256)
    newval1 = startval1*2 : newval2 = startval2/2
    for inc = 1 to 2
        newval1 = newval1/2 : newval2 = newval2*3
        k = 0 : seed = rnd(1) : amplitude = newval1 : frequence = newval2
        oldx = 0 : Perlin
    next inc
    oldrange = range(0) : pen rgb(30,colg,30)
    for i = 0 to w
        uppery = oldrange + h-100
        if uppery > h then uppery = h
        if uppery < 9 then uppery = 9
        move i-1,-uppery : draw i-1,-h : oldrange = range(i)
    next i
    lowmount = lowmount + lowr
END_SUB
rem ============================================================================
' Ma valeur aléatoire
SUB MyRnd()
    seed = (221*seed) + 2113 : seed = seed-(INT(seed/10000)*10000)
    a = seed/10000
END_SUB
rem ============================================================================

rem =================================================
rem          Couleurs
rem =================================================

dim a,b,c,d,i,x,y
mode 3,"Couleurs : <ESC> pour sortir ...",800,600
for i = 1 to 30
    randomize timer
'    cls
    a = 122 : b = rnd^2 : c = rnd^2 : d = rnd^2
    for x = 1 to 800
        for y = 1 to 600
            pen rgb(a+a*sin(b*x),a+a*cos(c*x),a+a*sin(d*x))
            plot x,y
        next y
        sleep 1
        if inkey$() = "ESCAPE" then end
    next x
next i

while inkey() = "" : wend
rem ========================================================

' ============================================================================
'                          Systeme planetaire
' ============================================================================
' Une courbe parametrique est l'ensemble des positions prises par un
' point M(x,y) dont les coordonnees sont fonctions d'un parametre :
' M = (x(t),y(t)). Si ce parametre est le temps, il s'agit alors de la
' trajectoire du point.
' ============================================================================
' Rappel : Un point M se deplacant a une vitesse f sur un cercle de rayon
' R centre en (x0,y0) a pour coordonnees :
'          _______________________
'         |                       |
'         |  x = x0 + R*cos(f*t)  |
'         |  y = y0 + R*sin(f*t)  |
'         |_______________________|
'
' ============================================================================
' On souhaite representer les trajectoires de n points P(1), P(2) ... P(n),
' P(i) tournant autour de P(i-1), P1 etant en rotation autour de l'origine.
' P(i) tourne avec un rayon r(i) et une vitesse f(i) ; on en deduit ses
' coordonnees en fonction du temps t:
'
'         x(i) = x(i-1) + r(i) * cos(f(i) * t)
'         y(i) = y(i-1) + r(i) * sin(f(i) * t)
'
'         i = 1..n, x(0) = y(0) = 0
'
' On fait varier t entre 0 et 360 degres soit 2*pi rad.
' Les rayons et vitesses respectives sont dans des DATA
' ============================================================================

const NP = 5  ' Nombre de planetes : 2 a 5

' Pour chaque planete : r, f, couleur

data 100,  3, &hFF0000
data  70, 10, &h00FF00
data  40,  3, &hFFFF00
data  10,  2, &h00FFFF
data   5,  3, &hFFFFFF

dim r(NP), f(NP), col%(NP), x(NP), y(NP)

dim i%, t, phi

for i% = 1 to NP
  read r(i%), f(i%), col%(i%)
next i%

mode 3, "Systeme planetaire (" & NP & " planetes)", 800, 600, 1, 2

paper &h000066 : cls

for i% = 1 to NP
  pen col%(i%)
  locate 3, 2 + 2 * i%
  print chr$(231) & " Trajectoire de P" & i%
next i

pen &hFFFFFF

for i% = NP to 2 step -1
  locate 3, 20 - i%
  print "P" & i% & " tournant autour de P" & i% - 1 & ","
next i%

locate 3, 19 : print "elle-meme en rotation"
locate 3, 20 : print "autour de l'origine"

origin 500, 300, 240, 760, 560, 40, &h000099, &h00FFFF

pen &hFFFFFF
pie 0, 0, 20

repeat
  for i% = 1 to NP
    phi = f(i%) * t
    x(i%) = x(i% - 1) + r(i%) * cos(phi)
    y(i%) = y(i% - 1) + r(i%) * sin(phi)
  next i%

  for i% = 1 to NP
    pen col%(i%)
    pie x(i%), y(i%), 2
  next i%

  t = t + 0.005
  sleep 20
until inkey$() = "ESCAPE"

rem ============================================================================
rem          Courbes en coordonnées polaires
rem              Les jolis papillons
rem                 Par Papydall
rem ============================================================================
dim x0,y0,s

mode 3,"Les jolis papillons par Papydall ... Une touche pour quitter ...",900,700
origin 0,700
paper rgb(150,100,50) : cls
x0 = 450 : y0 = -350
locate 4,2
print "Equation polaire : r = a + b * cos(2*t) + sin(5*t)^3"
for s = 2 to 100
    Papillon(x0,y0,s)           : ' papillon centre
    Papillon(x0/2,y0*.25,s/3)   : ' papillon haut gauche
    Papillon(x0/2,y0*1.7,s/3)   : ' papillon bas gauche
    Papillon(x0*1.5,y0*.25,s/3) : ' papillon haut droite
    Papillon(x0*1.5,y0*1.7,s/3) : ' papillon bas droite    
next s
while inkey$() = ""
   locate 12,12
   pen rgb(255,255,0)  
   print "Que c'est beau ! Que c'est joli !" : sleep 1000
   locate 12,12
   pen rgb(0,0,255)  
   print "Que c'est beau ! Que c'est joli !" : sleep 1000
wend
rem ============================================================================
SUB Papillon(x0,y0,s)
    dim r,a,b,t,x,y,cr,cg,cb,n,p
    a = 1.6 : b = 1.1
    cr = abs(3*s-255) : cg = 150+s : cb = abs(2*s-255)
    p = pi/180
    pen rgb(cr,cg,cb)
    plot x0 + s*(a+b),y0
    for t = 0 to 2*pi step p
        r = a + b * cos(2*t) + sin(5*t)^3
        x = x0 + s*r*cos(t) : y = y0 + s*r*sin(t)
        draw x,y
        for n = 1 to 2000 : next n : ' temporisation à adapter
    next t
END_SUB
rem ============================================================================

rem ============================================================================
rem                  Les nombres de Kaprekar
rem ============================================================================
' Un nombre n est un nombre de Kaprekar en base 10, si la representation decimale
' de n² peut etre separee en une partie gauche u et une partie droite v tel que
' u + v = n.
rem ============================================================================
' Exemples :
' 45²   = 2025,     comme 20  + 25    = 45,  45   est un nombre de Kaprekar.
' 703²  = 494209    comme 494 + 209   = 703, 703  est un nombre de Kaprekar.
' 4879² = 23804641, comme 238 + 04641 = 4879 (le 0 de 046641 est inutile,
' je l'ai juste place pour eviter toute confusion), alors 4879 est un nombre
' de Kaprekar.
rem ============================================================================
rem &&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
rem ============================================================================
dim i% ,nb%, n$
mode 2
locate 2,1
print "Liste des nombres de Kaprekar < 1000000       Une touche pour quitter ..."
for i% = 1 to 1000000        : ' trouver tous les nombres de Kaprekar < 1 000 000
    if IsKaprekar(i%) = 1 then
       nb = nb + 1 : ' compteur des nombres de Kaprekar trouves        
       n$ = str$(i)
       while len(n$) < 6 : n$ = " " + n$ : wend
       locate 5,nb+2
       print n$ + " est un nombre de Kaprekar"        
     end_if
  next i
while inkey() = "" : wend
end
rem ============================================================================
' Renvoie 1 si n est un nombre de Kaprekar, 0 sinon
FUNCTION IsKaprekar(n%)
    dim a,b,p,q
    if n = 1 then
       return 1 : ' le nombre 1 est considere comme nombre de Kaprekar
    end_if
    q = n*n : p = 10
    while p < q
        a = q mod p : b = int(q/p)
        if (a > 0) and ((a+b) = n) then return 1  
        p = p*10
    end_while
    IsKaprekar = 0
END_FUNCTION
rem ============================================================================

' ============================================================================
'                  Les nombres de Kaprekar
' ============================================================================
' Un nombre n est un nombre de Kaprekar en base 10, si la representation decimale
' de n^2 peut etre separee en une partie gauche u et une partie droite v tel que
' u + v = n.
' ============================================================================
' Exemples :
' 45^2   = 2025,     comme 20  + 25    = 45,  45   est un nombre de Kaprekar.
' 703^2  = 494209    comme 494 + 209   = 703, 703  est un nombre de Kaprekar.
' 4879^2 = 23804641, comme 238 + 04641 = 4879 (le 0 de 046641 est inutile,
' je l'ai juste place pour eviter toute confusion), alors 4879 est un nombre
' de Kaprekar.
' ============================================================================

dim i% ,nb%, n$
mode 2
locate 2,1
print "Liste des nombres de Kaprekar < 1000000       Une touche pour quitter ..."
for i% = 1 to 1000000        : ' trouver tous les nombres de Kaprekar < 1 000 000
    if IsKaprekar(i%) = 1 then
       nb = nb + 1 : ' compteur des nombres de Kaprekar trouves        
       n$ = str$(i)
       pen CL_VERT_VIF
       locate 10 - len(n$), nb + 2
       print n$
       pen CL_JAUNE_VIF
       locate 12, nb + 2
       print "est un nombre de Kaprekar"        
     end_if
  next i
while inkey() = "" : wend
end

' ============================================================================
' Renvoie 1 si n est un nombre de Kaprekar, 0 sinon
FUNCTION IsKaprekar% (n%)
    dim a,b,p,q
    if n% = 1 then
       return 1 : ' le nombre 1 est considere comme nombre de Kaprekar
    end_if
    q = n% * n% : p = 10
    while p < q
        a = q mod p : b = int(q/p)
        if (a > 0) and ((a+b) = n%) then return 1  
        p = p*10
    end_while
    return 0
END_FUNCTION

rem =================================================================
rem       Fonction récursive de Ackermann
rem =================================================================
dim m,n
m = 3

mode 2,"Calcul de la fonction d'Ackermann"
for n = 0 to 10
    locate 2,n+2
     ? "Acker(" & m & "," & n & ") = " & Acker(m,n)
next n
locate 2,20
? "Une touche pour quitter ...."
while inkey$() = "" : wend
rem ===================================================================
rem                      A T T E N T I O N
rem ===================================================================
' Le calcul de la fonction d'Ackerman est très lourd car contenant deux
' appels récursifs imbriqués (récursivité du second ordre) :
' l'appel récursif appelle un second appel récursif, ce qui complique
' beaucoup le calcul.
' Au-delà de m = 3, avec par exemple
' Acker(3,0) = 5, Acker(3,1) = 13, Acker(3,2) = 29, Acker(3,3) = 61
' Acker(3,4)) = 125, Acker(3,5) = 253, Acker(3,6) = 509, etc..
' Acker(3,10) = 8189
' les valeurs s'envolent très vite :
' Acker(4,0) = 13 mais Acker(4,1) = 65533  et Acker(4,2) = 2^65536 - 3 !
rem ====================================================================
function Acker(m,n)
   if (m <> 0 and n <> 0) then
      Acker = Acker(m-1,Acker(m,n-1))
   else
      if m = 0 then Acker = n+1
      if n = 0 then Acker = Acker(m-1,1)
   end_if
end_function
rem ====================================================================

print "Acker(" & m & "," & n & ") = " & Acker(m,n)

rem =================================================================
rem                         TAPIS VERT
rem          ADAPTATION D`UN PROGRAMME DU MEME NOM
rem                PARU DANS "SCIENCE & JEUX"
rem          SOUS LA PLUME DE "Henri-Pierre Penel"
rem =================================================================
label donnees, boucle
dim c,i,h,v,ch,sd,m,gn,ha,sc,x$,tc$,cc$,co$,pc$,k$,r$

cls
mode 3,"TAPIS VERT",600,500
pen cl_rouge_vif : cls

rem =================================================================
REM             DONNEES SYMBOL DES GRAPHIQUES
REM =================================================================
rem               TREFLE (128,129 + 130,131)
rem =================================================================
symbol 128,1,3,7,7,3,49,121,255
symbol 129,128,192,224,224,192,140,158,255
symbol 130,255,121,49,3,7,31,0,0
symbol 131,255,158,140,192,224,248,0,0
rem =================================================================
rem               PIQUE (132,133 + 130,131)
rem =================================================================
symbol 132,1,3,7,15,31,63,127,255
symbol 133,128,192,224,240,248,252,254,255
rem =================================================================
rem              CARREAU (132,133 + 134,135)
rem =================================================================
symbol 134,255,127,63,31,15,7,3,1
symbol 135,255,254,252,248,240,224,192,128
rem =================================================================
rem              COEUR (136,136 + 134,135)
rem =================================================================
symbol 136,0,0,24,60,126,255,255,255
rem =================================================================
rem              CERCLE (137,138,139 + 140," ",141 + 142,143,144)
rem =================================================================
symbol 137,0,0,0,0,3,6,12,8
symbol 138,0,0,0,126,195,0,0,0
symbol 139,0,0,0,0,192,96,48,16
symbol 140,8,24,16,16,16,16,24,8
symbol 141,16,24,8,8,8,8,24,16
symbol 142,8,12,6,3,0,0,0,0
symbol 143,0,0,0,195,126,0,0,0
symbol 144,16,48,96,192,0,0,0,0
rem =================================================================
rem   INITIALISATION DES VARIABLES ET DONNEES DES CARTES A TIRER
REM =================================================================
h = 0 : v  = 0 : ch = 0
m = 0 : sd = 0 : gn = 0
donnees:
' Seules sont utilisées les cartes comprise entre le 7 et l'AS
' Pour des problèmes de présentation du jeu, le numéro 10 est écrit
' en chiffre romain ; il sera donc affiché "X"
' 1 pour AS et X pour 10
' R pour Roi; D pour Dame; V pour Valet;
data "1", "R", "D", "V", "X", "9", "8", "7"
rem =================================================================
rem                      PAGE DE PRESENTATION
rem =================================================================
locate 5,2  : ? chr$(128) + chr$(129)
locate 5,3  : ? chr$(130) + chr$(131)
locate 15,2 : ? chr$(132) + chr$(133)
locate 15,3 : ? chr$(134) + chr$(135)
locate 25,2 : ? chr$(136) + chr$(136)
locate 25,3 : ? chr$(134) + chr$(135)
locate 35,2 : ? chr$(132) + chr$(133)
locate 35,3 : ? chr$(130) + chr$(131)
rem ==================================================================
rem                MISE EN PLACE DE LA GRILLE DU JEU
rem ==================================================================
pen cl_jaune_vif
for i = 5 to 35 step 10
    locate i,5 : ? chr$(137) + chr$(138) + chr$(139)
    locate i,6 : ? chr$(140) + " " + chr$(141)
    locate i,7 : ? chr$(142) + chr$(143) + chr$(144)
next i
boucle:
paper cl_bleu_ciel : pen cl_bleu_vif
for v = 12 to 24 step 4
    restore donnees
    for h = 5 to 33 step 4
        read x$
        locate h,v : ? "   "
        locate h,v+1 : ? " " + x$ + " "
        locate h,v+2 : ? "   "
    next h
next v
paper cl_bleu : pen cl_jaune_vif
locate 2,13 : ? chr$(128) + chr$(129)
locate 2,14 : ? chr$(130) + chr$(131)
locate 2,17 : ? chr$(132) + chr$(133)
locate 2,18 : ? chr$(134) + chr$(135)
locate 2,21 : ? chr$(136) + chr$(136)
locate 2,22 : ? chr$(134) + chr$(135)
locate 2,25 : ? chr$(132) + chr$(133)
locate 2,26 : ? chr$(130) + chr$(131)
rem =================================================================
rem                        CHOIX DES CARTES
rem =================================================================
tc$ = "" : cc$ = "" : co$ = "" : pc$ = ""
locate 2,10 : ? "VOTRE CHOIX A TREFLE ?  "
c = 12 : Marquage_Grille : tc$ = k$
locate 2,10 : ? "VOTRE CHOIX A CARREAU ? "
c = 16 : Marquage_Grille : cc$ = k$
locate 2,10 : ? "VOTRE CHOIX A COEUR ?   "
c = 20 : Marquage_Grille : co$ = k$
locate 2,10 : ? "VOTRE CHOIX A PIQUE ?   "
c = 24 : Marquage_Grille : pc$ = k$
rem =================================================================
rem                        CHOIX DE LA MISE
rem =================================================================
' ________________________________________________________________________
'| Je n'arrive pas à faire accepter à Crocodile Basic l'instruction INPUT |
'| pour le choix de la mise (variable m).                                 |
'| Le programme détermine lui-même une valeur aléatoire de cette variable |
'|________________________________________________________________________|

locate 2,10 : print "                         "
m = int(rnd*100) + 10
locate 2,10 : print "VOTRE MISE :  " & m
rem =================================================================
rem                 TIRAGE ALEATOIRE DES CARTES
rem =================================================================
sc = 0
locate 2,10 : ? "TIRAGE A TREFLE        "
ha = 6 : Tirage_Cartes
if tc$ = x$ then sc = sc + 1
locate 2,10 : ? "TIRAGE A CARREAU       "
ha = 16 : Tirage_Cartes
if cc$ = x$ then sc = sc + 1
locate 2,10 : ? "TIRAGE A COEUR         "
ha = 26 : Tirage_Cartes
IF co$ = x$ then sc = sc + 1
      
locate 2,10 : ? "TIRAGE A PIQUE         "
ha = 36 : Tirage_Cartes
IF pc$ = x$ then sc = sc + 1
rem =================================================================
rem                  DETERMINATION DES GAINS
rem =================================================================
locate 2,10 : ? "                        "
select sc
    case 0,1 : gn = 0
    case 2   : gn = 10*m
    case 3   : gn = 100*m
    case 4   : gn = 1000*m
end_select
rem =================================================================
rem                   DETERMINATION DU SOLDE
rem =================================================================
sd = sd + gn - m
locate 2,10 : ? "MISE : " & m & "  GAIN : " & gn & "  SOLDE : " & sd
locate 2,29 : ? "R pour Rejouer ..... Q pour Quitter"
rem =================================================================
rem              REBOUCLAGE JEU SUR FRAPPE TOUCHE
rem =================================================================
 
k$ = ""
while k$ = ""
      k$ = upper$(inkey$)
wend
locate 2,10 : ? "                                                   "
locate 2,11 : ? "                                                   "
if k$ = "R" then
   locate 2,29 : ? "                                     "        
   goto boucle
end_if  
  
end
rem =================================================================
rem =================================================================
SUB Marquage_Grille()
    ch = 0
    while ch = 0
        k$ = ""
        while k$ = ""
            k$ = upper$(inkey$)
        wend
        restore donnees
        for h = 5 to 33 step 4
            read x$
            if k$ = x$ then ch = h
        next h
    wend
    paper cl_bleu_ciel : pen cl_magenta
    locate ch,c : ? chr$(137) + chr$(138) + chr$(139)
    locate ch,c+1 : ? chr$(140)
    locate ch+2, c+1 : ? chr$(141)
    locate ch,c+2 : ? chr$(142) + chr$(143) + chr$(144)
    paper cl_bleu : pen cl_jaune_vif
END_SUB
rem =================================================================
SUB Tirage_Cartes()
    dim i,t,a,n,z
    
    for t = 1 to 5000
        restore donnees
        for a = 1 to 8
            read x$
            for z = 1 to 1000 : next z
            locate ha,6 : ? x$
        next a
    next t
    randomize timer
    n = int(rnd * 8 ) + 1
    restore donnees
    for i = 1 to n
        read x$
    next i
    locate ha,6 : ? x$
END_SUB
rem =================================================================

n = int(rnd * 8 ) + 1

? chr$(128, 129)  ' au lieu de : ? chr$(128) + chr$(129)

? chr$(31, 5, 2, 128, 129)  ' au lieu de : locate 5,2  : ? chr$(128) + chr$(129)

rem ============================================================================
rem                Fougère de Barnsley
rem                   Par Papydall
rem Ref : http://papydall-panoramic.forumarabia.com/t20-fougere-de-barnsley
rem ============================================================================
'  IFS : Iterated Function System (Système de fonction itérée)
' ------------------------------------------------------------
' C'est un type de fractales assez original qui a été introduit par Michael Barnsley.
' Ce type de fractales n'est pas facile à expliquer à des non-mathématiciens.
' Leur structure est décrite par un ensemble de fonctions affines qui calculent
' les transformations appliquées à chaque point par homothétie, translation et rotation.
' Chaque transformation utilise 2 fonctions pour calculer les nouvelles valeurs x1 et y1
' des coordonnées x et y de chaque point.
'   ____________________
'  |                    |
'  |  ax + by + e = x1  |
'  |  cx + dy + f = y1  |
'  |____________________|

' Enfin une probabilité comprise entre 0 et 1 est associée à chaque transformation.
' Ces images sont donc construites par un processus aléatoire :
' On voit apparaître sur l'écran des points de plus en plus nombreux qui dessinent
' une forme floue, puis de plus en plus précise.
' En général le programme permet de fixer le critère d'arrêt du calcul.
' Plus le temps choisi est long, plus les images sont précises.

rem ============================================================================

dim NbPoints,p,p1,p2,p3,x,y,n,xt,i
NbPoints = 100000               : ' nombre des points à modifier éventuellement
p1 = .77 : p2 = .89 :  p3 = .99 : ' Pourcentage de probabilités
x = 0    : y  = 0               : ' point initial

mode 3,"FOUGERE DE BARNSLEY PAR PAPYDALL",1200,800
paper cl_noir : cls
locate 20,2 : print "... Veuillez patienter ... "
randomize timer
for n = 1 to NbPoints
    p = Rnd() : ' 0 <= p < 1
    xt = x
    if p < p1 then        : ' transformation T1
       x =  0.85 * x  + 0.04 * y + 0.075 : y = -0.04 * xt + 0.85 * y + 0.18
    else
       if p < p2 then     : ' transformation T2
           x = 0.20 * x  - 0.26 * y + 0.4 : y = 0.23 * xt + 0.22 * y + 0.045
       else
           if p < p3 then : ' transformation T3
              x = -0.15 * x  + 0.28 * y + 0.575 : y =  0.26 * xt + 0.24 * y - 0.086
           else           : ' transformation T4
              x = 0.5 :  y = 0.16 * y
           end_if
       end_if
    end_if
    if n > 100 then  : ' pour éviter de tracer des points parasites pendant les 1ères itérations
       pen rgb(0,255,0)                   : plot  600*x-150, 200+500*y : ' 1ère fougère
       pen rgb(255,(n mod 255),0)         : plot 750-600*x, 700-500*y  : ' 2ème fougère
       pen rgb((n mod 255),(n mod 255),0) : plot 400+ 600*x, 200+500*y : ' 3ème fougère
       pen rgb(0,(n mod 255),255)         : plot 1300-600*x, 700-500*y : ' 4ème fougère
      
       for i = 1 to 10 : ' 10 petites fougères en bas de l'écran
           pen rgb(rnd*25*i,rnd*255,rnd*25*i)
           plot 1000-100*i+200*x,20+150*y
       next i
    end_if
next n
while inkey$ = ""
    print chr$(7) : print chr$(7) : print chr$(7) : ' bip ... bip ... bip
    paper cl_blanc
    pen cl_bleu_vif  : locate 20,2 : print " Une touche pour sortir ... " : sleep 1000
    print chr$(7) : print chr$(7) :print chr$(7) :  ' bip ... bip ... bip
    pen cl_rouge_vif : locate 20,2 : print " Une touche pour sortir ... " : sleep 1000
wend
rem ============================================================================

rem =================================================================
rem                    FRACTALES.BAS
rem =================================================================
mode 3,"TRACE DES FRACTALES PAR PAPYDALL",640,480
dim x,y,lon,ang,nbre,boucle
 
x = 10  : y = 140 : nbre = 5  : init : VonKoch(nbre,620,0)       : locate 5,2  : ? "Courbe de Von Kock simple"   : Pause
x = 170 : y = 120 : nbre = 4  : Init : VonKockComplexe           : locate 5,2  : ? "Courbe de Von Kock complexe" : Pause
x = 120 : y = 300 : nbre = 15 : Init : Dragon(nbre,-1,300,0)     : locate 10,2 : ? "Courbe du Dragon"            : Pause
x = 150 : y = 120 : nbre = 9  : Init : Sierpinsky(nbre,-1,350,0) : locate 10,2 : ? "Triangle de Sierpinsky"      : Pause
x = 150 : y = 100 : nbre = 5  : Init : Triangle(nbre,300,x,y)    : locate 10,2 : ? "Triangle de Sierpinsky"      : Pause
x = 320 : y = 250 : nbre = 5  : Init : plot 8,87 : Peano(x,y,-3*pi/4,120,1,nbre) : locate 10,2 : ? "Courbe de Peano" : pause
x = 80  : y = 10  : Init : nbre = 5
for boucle = nbre to 0 step -1
    pen rgb(250-boucle*50,boucle*50,250-boucle*50) : Carre(boucle,x,y,450,0)
next boucle
pause

x = 80  : y = 170 : nbre = 10 : Init : Galaxie(nbre,500,0) : locate 18,2 : ? "Galaxie" : pause
x = 330 : y = 320 : nbre = 8  : Init : pen cl_vert_vif : Feuille(nbre,x,y,300,-pi/2) : locate 18,2 : ? "Feuille"

while inkey$() = ""
    pen cl_rouge : locate 8,28 : ? "Une touche pour sortir ..." : sleep 200
    pen cl_blanc : locate 8,28 : ? "Une touche pour sortir ..." : sleep 200
wend
rem ==================================================================
SUB Init()
    paper cl_noir : plot x,y :  cls
    pen cl_jaune_vif
END_SUB
rem ==================================================================
SUB Pause()
    sleep 2000
    locate 1,2 : string$(80," ")

END_SUB
rem ==================================================================
SUB VonKoch(nbre,lon,ang)
       if nbre = 0 then
       x = x + lon*cos(ang)
       y = y - lon*sin(ang)
       draw x,y
    else
       VonKoch(nbre-1,lon/3,ang)
       VonKoch(nbre-1,lon/3,ang-pi/3)
       VonKoch(nbre-1,lon/3,ang+pi/3)
       VonKoch(nbre-1,lon/3,ang)
   end_if
END_SUB
rem =================================================================
SUB VonKockComplexe()
    VonKoch(nbre,300,0)
    VonKoch(nbre,300,-2*pi/3)
    VonKoch(nbre,300,-4*pi/3)
    VonKoch(nbre,300,5*pi/3)
    VonKoch(nbre,300,pi/3)
    VonKoch(nbre,300,pi)
  
END_SUB
rem =================================================================
SUB Dragon(nbre,s,lon,ang)  
    if nbre = 0 then
       x = x + lon * cos(ang)
       y = y - lon * sin(ang)
       draw x,y
    else
       Dragon(nbre-1,+1,lon/sqr(2),ang-s*pi/4)
       Dragon(nbre-1,-1,lon/sqr(2),ang+s*pi/4)
    end_if
END_SUB
rem ====================================================================
SUB Sierpinsky(nbre,s,lon,ang)
    if nbre = 0 then
       x = x + lon * cos(ang)
       y = y - lon * sin(ang)
       draw x,y
    else    
       Sierpinsky(nbre-1,-s,lon/2,ang+s*pi/3)
       Sierpinsky(nbre-1,+s,lon/2,ang)
       Sierpinsky(nbre-1,-s,lon/2,ang-s*pi/3)
   end_if
END_SUB
rem ======================================================================
SUB Peano(x,y,orig,lon,sens,nbre)
    if nbre = 0 then
       draw x,y        
    else
       Peano(x+lon*cos(orig)*1.9,y+lon*sin(orig),orig,lon/2,-sens,nbre-1)
       Peano(x+lon*cos(orig+sens*pi/2)*1.9,y+lon*sin(orig+sens*pi/2),orig,lon/2,sens,nbre-1)
       Peano(x+lon*cos(orig+sens*pi)*1.9,y+lon*sin(orig+sens*pi),orig,lon/2,sens,nbre-1)
       Peano(x+lon*cos(orig+sens*3*pi/2)*1.9,y+lon*sin(orig+sens*3*pi/2),orig+pi,lon/2,-sens,nbre-1)
    end_if
END_SUB
rem =========================================================================
SUB Triangle(nbre,lon,x,y)
    if nbre = 0 then
       move x,y
       draw x+lon,y
       draw x+lon/2,y+lon*sqr(3)/2
       draw x,y
     else
          Triangle(nbre-1,lon/2,x,y)
          Triangle(nbre-1,lon/2,x+lon/2,y)
          Triangle(nbre-1,lon/2,x+lon/4,y+lon*sqr(3)/4)
     end_if
END_SUB
rem ===========================================================================
SUB Carre(nbre,x,y,lon,ang)
    if nbre = 0 then
       move x,y
       draw x + lon * cos(ang),y + lon * sin(ang)
       draw x + lon * sqr(2) * cos(ang+pi/4),y + lon * sqr(2) * sin(ang+pi/4)
       draw x + lon * cos(ang+pi/2),y + lon * sin(ang+pi/2)
       draw x,y
    else
       Carre(nbre-1,x+lon/4*cos(ang),y+lon/4*sin(ang),lon/sqr(8),ang+pi/4)
       Carre(nbre-1,x+3*lon/4*cos(ang),y+3*lon/4*sin(ang),lon/sqr(8),ang+pi/4)
       Carre(nbre-1,x+lon/2*cos(ang+pi/2)+lon/4*cos(ang),y+lon/2*sin(ang+pi/2)+lon/4*sin(ang),lon/sqr(8),ang+pi/4)
       Carre(nbre-1,x+lon/2*cos(ang+pi/2)+3*lon/4*cos(ang),y+lon/2*sin(ang+pi/2)+3*lon/4*sin(ang),lon/sqr(8),ang+pi/4)
    end_if
END_SUB
rem ===========================================================================
SUB Galaxie(nbre,lon,ang)
    if nbre = 0 then
       x = x + lon*cos(ang)
       y = y + lon*sin(ang)
       draw x,y
    else
          Galaxie(nbre-1,lon/sqr(3),ang+pi/6)
          Galaxie(nbre-1,lon/sqr(3),ang-pi/2)
          Galaxie(nbre-1,lon/sqr(3),ang+pi/6)
     end_if
END_SUB
rem ==============================================================================
SUB Feuille(nbre,x,y,lon,ang)
     plot x,400-y : draw x + lon * cos(ang),400-(y + lon * sin(ang))
     if nbre > 0 then
        Feuille(nbre-1,x+lon/4*cos(ang),y+lon/4*sin(ang),lon/3,ang+pi/3)
        Feuille(nbre-1,x+lon/4*cos(ang),y+lon/4*sin(ang),lon/3,ang-pi/3)
        Feuille(nbre-1,x+lon/2*cos(ang),y+lon/2*sin(ang),lon/5,ang+pi/3)
        Feuille(nbre-1,x+lon/2*cos(ang),y+lon/2*sin(ang),lon/5,ang-pi/3)
        Feuille(nbre-1,x+lon*3/4*cos(ang),y+lon*3/4*sin(ang),lon/9,ang+pi/3)
        Feuille(nbre-1,x+lon*3/4*cos(ang),y+lon*3/4*sin(ang),lon/9,ang-pi/3)
        Feuille(nbre-1,x+lon*3/4*cos(ang),y+lon*3/4*sin(ang),lon/9,ang)
     end_if
END_SUB
rem ===============================================================================

' ============================================================================
'                            Nombres narcissiques
' ============================================================================
' Un nombre narcissique (ou nombre d’Armstrong) de premiere espece, est
' un entier naturel n non nul qui est egal a la somme des puissances
' p-iemes de ses chiffres en base dix, ou p designe le nombre de chiffres de n
' Exemples:
' Tous les entiers de 1 a 9 sont narcissiques.
' 153   = 1^3 + 5^3 + 3^3 = 1 + 125 + 27 = 153  est un nombre narcissique d’ordre 3
' 93084 = 9^5 + 3^5 + 0^5 + 8^5 + 4^5 = 93084   est un nombre narcissique d’ordre 5
' ============================================================================
' Le programme calcule et affiche la liste de tous les nombres narcissiques
' d’ordre 1 a NMAX ; pour le compilateur, on peut aller facilement jusqu'a
' ordre 6 ou 7 soit NMAX = 9999999 et meme plus si vous disposez d'un bolide
' ============================================================================
' Note : il n’y a ancun nombre narcissique d’ordre 2
' ============================================================================

const NMAX = 9999999

dim n%, ordre%

print "Nombres narcissiques par Papydall"

for n = 1 to NMAX
  if EstNarcissique(n) = 1 then
    print using "######## est narcissique d'ordre #"; n; ordre
  end_if
next n

print "OK"

end

' ============================================================================
' Renvoie 1 si l'argument n est un nombre narcissique, sinon 0
function EstNarcissique% (n%)  

    dim total%, i%, nb$, c%(10)    
    nb$ = str$(n)
    ordre = len(nb$)  ' ordre est egal au nombres de chiffres de n  
    for i = 1 to ordre
        c(i) = val(mid$(nb$,i,1))  ' Le tableau C() contiendra les chiffres de n
        total = total + c(i)^ordre ' sommation des chiffres de n portes a la puissance ordre
    next i    
    if total = n then return 1 else return 0
end function

' ============================================================================

' &&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
' ============================================================================
' Voici une liste pour n = 3 jusqu’a n = 23

' Pour n = 3, il y a 4 nombres qui sont :
'    153; 370; 371; 407

' Pour n = 4, il y a 3 nombres qui sont :
'    1634 = 1^4 + 6^4 + 3^4 + 4^4 = 1634
'    8208 = 8^4 + 2^4 + 0^4 + 8^8 = 8208
'    9474 = 9^4 + 4^4 + 7^4 + 4^4 = 9474

' Pour n = 5, il y a aussi 3 nombres qui sont :
'    54748 ; 92727 ; 93084

' Pour n = 6, il y a un seul nombre qui est :
'    548834

' Pour n = 7, il y a 4 nombres qui sont :
'    1741725 ; 4210818 ; 9800817 ; 9926315

' Pour n = 8, il y a 3 nombres qui sont :
'    24678050 ; 24678051 ; 88593477

' Pour n = 9, il y a 4 nombres qui sont :
'    146511208 ; 472335975 ; 534494836 ; 912985153

' Pour n = 10, il y a un seul nombre qui est :
'    4679307774

' Pour n = 11, il y a 8 nombres qui sont :
'    321640499650 ; 32164049651 ; 40028394225 ; 42678290603 ;
'    44708635679 ; 49388550606 ; 82693916578 ; 94204591914

' Pour n = 12 et n = 13, il n’y a pas de solution

' Pour n = 14, il y a un seul nombre qui est :
'    28116440335967

' Pour n = 15, pas de solution

' Pour = 16, il y a 2 nombres qui sont :
'    4338281769391370 ; 4338281769391371

' Pour n = 17, il y a 3 nombres qui sont :
'    21897142587612075, 35641594208964132, 35875699062250035

' Pour n = 18, pas de solution

' Pour n = 19, il y a 4 nombres qui sont :
'    1517841543307505039, 3289582984443187032, 4498128791164624869, 4929273885928088826

' Pour n = 20, il y a un seul nombre qui est : 63105425988599693916

' Pour n = 21, il y a 2 nombres qui sont :
'    128468643043731391252, 449177399146038697307

' Pour n = 22, pas de solution

' Pour n = 23, il y a 5 nombres qui sont :
'    21887696841122916288858, 27879694893054074471405, 27907865009977052567814,
'    28361281321319229463398, 35452590104031691935943

' Bon divertissement avec ces nombres !
' ============================================================================