Les programmes de papydall

' ============================================================================
'                            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
' ============================================================================

dim NMAX : NMAX = 9

dim n%, ordre%, result%
dim total%, i%, nb$, c%(10)

print "Nombres narcissiques par Papydall"

for n% = 1 to NMAX
  EstNarcissique(n%)
  if result% = 1
    print str$(n%)+ " est narcissique d'ordre #"+ str$(ordre%)
  end_if
next n%

print "OK"

end

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

       
    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% + power(c%(i%),ordre%) : ' sommation des chiffres de n portes a la puissance ordre
    next i%
     
    if (total% = n)
      result%= 1
    else
      result%=0
    end_if
end_sub

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

' &&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
' ============================================================================
' 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 !
' ============================================================================

mode 3, "", 600, 600

paper CL_BLANC : cls

pen CL_BLEU
fl_font FL_TIMES_BOLD_ITALIC, 45
fl_text_justify "Cadre étoilé", 0, 340, 600, 100, FL_ALIGN_CENTER

CadrEtoile 100, 50, 400, 5, 2

fl_image_display

while inkey$() = "" : wend


sub CadrEtoile(x0, y0, w, gen%, tr%)
 ' d'apres PAPYDALL
 ' Cadre fantaisie, forme gen = 1 (triangle) a 5 (etoile)
 ' Trace en x0, y0, w = largeur de la figure (enveloppe ~ carree)
 ' tr = 1 pour polygone, autre valeur pour cercles
 ' Parametres actuels: couleur et epaisseur de trait.

 const sin60 = 0.8660254037844386  ' sin(60) pour les deplacements
 const cos60 = 0.5                 ' cos(60)

 dim p4%, i%, j%, k%, dx, dy
 
 if gen > 5 then gen = 5
 i = 2*gen-2 : p4 = 2^i

 dim x(12 * p4), y(12 * p4)
 
 ' Init
 
 x(0) = x0: y(0) = y0+2+w*Sin60           ' 1er point
 x(1) = x(0)+w*Cos60: y(1) = y(0)-w*Sin60 ' 2eme point
 x(2) = x(0)+w: y(2) = y(0)               ' 3eme point
 x(3) = x(0): y(3) = y(0)
 
 if gen > 1 then
   ' Generer
   for k = 2 to gen
     for j = p4 * 3 to 1 step -1 ' Intercaler les 3 nouveaux points  
       x(j*4) = x(j) : y(j*4) = y(j)
     next j
     for j = 0 to p4 * 3 - 1     ' On intercale les 3 nouveaux points
       i = 4*j
       dx = (x(i+4)-x(i))/3 : dy = (y(i+4)-y(i))/3 ' Coupe en 3
       x(i+1) = x(i)+dx : y(i+1) = y(i)+dy         ' Du 1/3 aux 2/3
       x(i+2) = x(i+1)+cos60*dx+sin60*dy           ' nouveau point,
       y(i+2) = y(i+1)-sin60*dx+cos60*dy           ' sommet triangle equilateral
       x(i+3) = x(i)+2*dx : y(i+3) = y(i)+2*dy    
     next j  
   next k
 end_if  

 ' Dessiner
 fl_move x(0), y(0)  ' on se positionne sur le 1er point
 pen CL_ROUGE_VIF
 if tr = 1 then
   for i = 1 to 3*p4 ' on trace de point en point
     fl_draw x(i), y(i)
   next i
 else
   for i = 1 to 3*p4
     pen CL_JAUNE_VIF
     fl_pie x(i), y(i), 5
     pen CL_ROUGE_VIF
     fl_arc x(i), y(i), 5
   next i    
 end_if  
end_sub

rem ============================================================
rem                          FOUGERE
rem    Adaptation par Papydall d un code en Free Basic
rem ============================================================
dim  xx,yy,rr,AA,BB,CC,DD,EE,FF,newX,newY,i,k

mode 3,"FOUGERE DE BARNESLEY",1000,600
paper rgb(0,0,0) : cls
locate 15,3 : ? "<ESC> pour sortir"
k = 1
repeat

   FOR i = 1 TO 1000000
      rr = RND(1)
      IF rr <= 0.1 then
         AA = 0 : BB = 0 : CC = 0 : DD = 0.16 : EE = 0 : FF = 0
      ELSE
         IF rr > 0.1  AND  rr <= 0.86 then
            AA = .85 : BB = .04 : CC = -.04 : DD = .85 : EE = 0 : FF = 1.6
         ELSE
            IF rr > 0.86  AND  rr <= 0.93 then
               AA = .2 : BB = -.26 : CC = .23 : DD = .22 : EE = 0 : FF = 1.6
            ELSE
               AA = -.15 : BB = .28 : CC = .26 : DD = .24 : EE = 0 : FF = .44
            END_IF
         END_IF
      END_IF
          
      newX = AA * xx + BB * yy + EE
      newY = CC * xx + DD * yy + FF
      xx = newX
      yy = newY

      select k    
         case 1 : pen rgb( 255,i/4000,255-i/4000)
                  plot 16 + 96 * yy, 300 - 96 * xx
         case 2 : pen rgb( i/4000,255-i/4000,255)
                  plot 16 + 96 * yy, 300 - 96 * xx
         case 3 : pen rgb( i/4000,255,255-i/4000)
                  plot 16 + 96 * yy, 300 - 96 * xx
         case 4 : pen rgb( 255,255-i/4000,i/4000)
                  plot 16 + 96 * yy, 300 - 96 * xx
         case 5 : pen rgb( 255-i/4000,255,i/4000)
                  plot 16 + 96 * yy, 300 - 96 * xx
         case 6 : pen rgb( 255-i/4000,i/4000,255)
                  plot 16 + 96 * yy, 300 - 96 * xx      
      
      end_select
     NEXT i
   sleep 10  
   k = k + 1
   if k = 7 then k = 1
  
until inkey$() = "ESCAPE"
rem ============================================================

rem ==========================================================================================================
rem            Le Cheval (la mascotte) de Free Basic en Cocodile Basic
rem                Par Papydall - 04 / 11 / 2020
rem Ref : https://www.freebasic-portal.de/code-beispiele/grafik-und-fonts/fb-pferd-in-freebasic-zeichen-8.html
rem ==========================================================================================================
dim x,y,w,h,zoom,x0,y0
w = 900 : h = 600

mode 3," La mascotte (le Cheval) de Free Basic en Cocodile Basic ... Une touche pour sortir ...",w,h
paper rgb(255,255,255) : cls
pen rgb(0,0,0)

x0 = 20  : y0 = 10    : zoom = 28 : Cheval(x0,y0,zoom) : ' Grand cheval
x0 = 660 : y0 = 50    : zoom = 8  : Cheval(x0,y0,zoom) : ' Petit cheval bas-droite
x0 = 750 : y0 = h-100 : zoom = 5  : Cheval(x0,y0,zoom) : ' Petit cheval haut-droite
x0 = 0   : y0 = 55    : zoom = 4  : Cheval(x0,y0,zoom) : ' Petit cheval bas-gauche
x0 = 10  : y0 = h-100 : zoom = 4  : Cheval(x0,y0,zoom) : ' Petit cheval haut-gauche

repeat : until len(inkey())
end

rem ==========================================================================================================
SUB Cheval(x0,y0,zoom)
    restore  
    if zoom < 4  then zoom = 4
    if zoom > 28 then zoom = 28
    READ X, Y
    plot x0 + zoom * x, y0 + zoom *y  
    READ X, Y
    WHILE x <> 0 AND y <> 0
        ' SLEEP 5  : ' pour obsever le tracé
        draw x0 + zoom * x,y0+ zoom * y
        READ X, Y
    wend
    move x0+15*zoom,y0+10*zoom : fill 0 : move x0+15*zoom,y0+int(1.5*zoom)  : fill 0
END_SUB
rem ==========================================================================================================
DATA 0.842,1.052,0.842,1.649,5.296,1.649,5.595,1.855
DATA 5.913,2.028,6.233,2.194,6.541,2.384,6.733,2.576,6.906,2.851
DATA 7.060,3.190,7.197,3.573,7.317,3.981,7.423,4.397,7.516,4.800
DATA 7.597,5.173,7.668,5.496,7.729,5.751,7.782,5.918,7.815,5.974
DATA 7.876,6.075,7.981,6.274,8.143,6.622,8.373,7.172,8.686,7.976
DATA 8.960,8.571,9.034,8.733,8.830,8.824,8.392,8.659,7.954,8.508
DATA 7.784,8.487,7.601,8.471,7.395,8.460,7.153,8.453,6.867,8.449
DATA 6.116,8.449,5.630,8.451,5.057,8.452,4.384,8.453,4.144,8.119
DATA 3.980,7.715,4.065,7.361,4.215,7.044,4.420,6.761,4.668,6.505
DATA 4.948,6.271,5.250,6.055,5.562,5.850,5.778,5.645,6.015,5.478
DATA 6.421,5.367,6.742,5.271,6.921,5.178,7.105,4.836,7.123,4.472
DATA 7.005,4.183,6.803,3.964,6.641,3.871,6.487,3.890,6.309,4.005
DATA 6.077,4.200,5.758,4.459,5.321,4.768,4.735,5.110,4.641,5.211
DATA 4.445,5.452,4.177,5.794,3.868,6.198,3.548,6.624,3.246,7.033
DATA 2.993,7.387,2.819,7.644,2.753,7.767,2.774,8.165,2.859,8.538
DATA 3.020,8.867,3.272,9.131,3.625,9.311,4.420,9.563,5.023,9.750
DATA 5.461,9.885,5.756,9.979,5.933,10.040,6.017,10.090,6.032,10.140
DATA 5.946,10.470,5.873,10.810,5.830,11.140,5.835,11.460,5.904,11.790
DATA 6.054,12.120,6.226,12.400,6.409,12.670,6.591,12.950,6.763,13.240
DATA 6.912,13.530,7.030,13.850,7.101,14.260,7.094,14.700,7.023,15.130
DATA 6.902,15.510,6.747,15.810,6.570,15.970,6.403,15.930,6.092,15.770
DATA 5.735,15.550,5.431,15.310,5.277,15.100,5.174,14.540,5.157,14.260
DATA 5.122,14.130,4.885,13.950,4.557,13.890,4.191,13.920,3.841,14.020
DATA 3.559,14.170,3.428,14.300,3.353,14.480,3.322,14.740,3.318,15.080
DATA 3.326,15.520,3.332,16.100,3.530,16.370,3.655,16.700,3.728,17.090
DATA 3.771,17.500,3.805,17.900,3.853,18.270,3.934,18.590,4.072,18.810
DATA 4.357,19.060,4.706,19.310,5.085,19.520,5.459,19.680,5.794,19.750
DATA 6.056,19.710,6.208,19.540,6.733,19.540,7.059,19.540,7.265,19.540
DATA 7.431,19.540,7.637,19.540,7.963,19.540,8.488,19.540,8.782,19.390
DATA 9.234,19.250,9.553,19.080,9.893,18.880,10.230,18.650,10.560,18.420
DATA 10.840,18.190,11.070,17.990,11.230,17.820,11.700,17.160,11.970,16.690
DATA 12.110,16.370,12.150,16.170,12.150,16.050,12.170,15.980,12.350,15.740
DATA 12.570,15.550,12.820,15.420,13.100,15.330,13.400,15.280,13.730,15.270
DATA 14.070,15.280,14.430,15.330,14.800,15.390,15.180,15.470,15.560,15.560
DATA 15.950,15.650,16.330,15.750,16.710,15.840,17.080,15.920,17.450,15.990
DATA 17.790,16.030,18.040,16.040,18.310,16.040,18.630,16.010,18.980,15.960
DATA 19.390,15.890,19.860,15.800,20.180,15.740,20.450,15.700,20.700,15.690
DATA 20.940,15.720,21.190,15.800,21.470,15.930,21.810,16.130,22.210,16.410
DATA 22.700,16.770,23.010,16.960,23.330,17.080,23.660,17.150,23.990,17.170
DATA 24.330,17.130,24.660,17.040,24.980,16.910,25.280,16.730,25.560,16.510
DATA 25.800,16.300,25.950,16.120,26.040,15.890,26.120,15.490,26.210,14.830
DATA 26.270,14.420,26.320,14.030,26.370,13.660,26.390,13.300,26.380,12.940
DATA 26.330,12.580,26.290,12.470,26.200,12.280,26.080,12.030,25.930,11.740
DATA 25.750,11.400,25.550,11.030,25.340,10.650,25.120,10.270,24.900,9.897
DATA 24.680,9.544,24.480,9.224,24.300,8.949,24.140,8.731,23.850,8.298
DATA 23.660,7.941,23.530,7.660,23.420,7.457,23.290,7.331,23.290,6.946
DATA 23.300,6.569,23.310,6.198,23.340,5.830,23.380,5.501,23.300,5.389
DATA 23.050,5.526,22.840,5.731,22.680,5.993,22.560,6.302,22.480,6.647
DATA 22.430,7.017,22.410,7.401,22.410,7.788,22.440,8.166,22.480,8.526
DATA 22.540,8.856,22.600,9.146,22.700,9.459,22.830,9.787,22.990,10.120
DATA 23.160,10.460,23.330,10.790,23.480,11.110,23.620,11.400,23.730,11.660
DATA 23.800,11.890,23.850,12.260,23.880,12.640,23.860,13.020,23.810,13.390
DATA 23.720,13.730,23.590,14.050,23.410,14.320,23.190,14.540,22.920,14.690
DATA 22.620,14.790,22.300,14.850,21.970,14.880,21.640,14.880,21.310,14.880
DATA 20.980,14.870,21.110,14.550,21.250,14.230,21.390,13.900,21.520,13.580
DATA 21.640,13.250,21.740,12.920,21.810,12.590,21.850,12.260,21.850,11.920
DATA 21.810,11.580,21.710,11.240,21.550,10.880,21.320,10.540,21.040,10.220
DATA 20.740,9.924,20.430,9.648,20.130,9.397,19.860,9.172,19.650,8.976
DATA 19.500,8.811,19.440,8.678,19.450,8.382,19.640,7.984,19.840,7.710
DATA 20.060,7.419,20.270,7.119,20.440,6.816,20.520,6.520,20.480,6.237
DATA 20.350,5.983,20.160,5.736,19.930,5.491,19.670,5.243,19.400,4.989
DATA 19.110,4.724,18.830,4.442,18.560,4.139,18.410,3.906,18.220,3.581
DATA 18.010,3.235,17.790,2.940,17.590,2.767,17.040,2.553,16.920,2.444
DATA 16.820,2.143,16.630,1.806,16.420,1.766,16.020,1.824,15.580,1.951
DATA 15.220,2.118,15.260,2.258,15.450,2.568,15.710,2.802,16.020,2.986
DATA 16.360,3.150,16.680,3.320,16.970,3.524,17.060,3.622,17.240,3.838
DATA 17.490,4.138,17.780,4.490,18.080,4.859,18.370,5.213,18.610,5.518
DATA 18.770,5.741,18.840,5.849,18.890,6.150,18.880,6.406,18.780,6.694
DATA 18.570,7.094,18.260,7.045,18.290,6.817,18.130,6.445,17.970,6.185
DATA 17.750,5.942,17.500,5.701,17.220,5.447,16.940,5.167,16.670,4.846
DATA 16.510,4.623,16.340,4.356,16.170,4.058,15.980,3.741,15.780,3.416
DATA 15.560,3.096,15.330,2.794,15.080,2.520,14.800,2.287,14.510,2.107
DATA 14.300,1.982,14.240,1.649,27.220,1.649,27.220,1.052,0.842,1.052
DATA 0.842,1.649,7.541,1.649,7.700,1.941,7.767,2.217,7.837,2.566
DATA 7.918,2.911,8.010,3.251,8.111,3.587,8.222,3.919,8.342,4.246
DATA 8.472,4.570,8.610,4.890,8.756,5.205,8.910,5.518,9.071,5.826
DATA 9.240,6.131,9.415,6.432,9.597,6.730,9.785,7.025,9.979,7.317
DATA 10.180,7.605,10.380,7.891,10.590,8.173,10.800,8.453,11.990,8.453
DATA 12.400,8.456,12.720,8.465,12.970,8.481,13.180,8.508,13.370,8.548
DATA 13.570,8.602,13.800,8.674,14.090,8.765,14.460,8.878,14.780,8.817
DATA 15.180,8.588,15.470,8.326,15.600,8.139,15.850,7.769,16.140,7.335
DATA 16.380,6.959,16.490,6.761,16.530,6.380,16.470,6.004,16.340,5.647
DATA 16.170,5.322,16.050,5.134,15.880,4.893,15.670,4.617,15.430,4.323
DATA 15.200,4.030,14.970,3.755,14.760,3.515,14.690,3.464,14.540,3.373
DATA 14.330,3.236,14.050,3.047,13.730,2.800,13.360,2.489,12.950,2.107
DATA 12.520,1.649,0.842,1.649,27.220,1.649,0,0
rem ==========================================================================================================

rem ===============================================================================
rem                            Coniques  
rem                    Par Papydall le 12 / 11 / 2020
rem ===============================================================================
const deg2rad = pi/180
dim w%,h%,zoom%
w = 900 : h = 600 : zoom = 100

mode 3,"Coniques par Papydall ... Une touche pour sortir ...",w,h : origin w/2,h/2
paper rgb(50,100,150) : cls

DrawConique

repeat : until len(inkey())
rem ==============================================================================
SUB DrawConique()
    dim e,r,t,x,y,passe,epsilon
    epsilon = 1e-3
    for passe = 1 to 2
        for e = 0.1 to 1 step 0.0001
            for t = epsilon to 360+epsilon : ' on commence à epsilon pour eviter une division par zero  
                r = e / (1-e*cos(deg2rad*t)) : x = r*cos(deg2rad*t) : y = r * sin(deg2rad*t)
                pen rgb(e*500 mod 255, e*1500 mod 255, e*250)
                if passe = 1 then
                   if t = epsilon then
                      move -zoom/2 - x*zoom, y*zoom
                   else
                      draw -zoom/2 - x*zoom, y*zoom
                   end_if
                else
                   if t = epsilon then
                      move zoom/2 + x*zoom, y*zoom
                   else
                      draw zoom/2 + x*zoom, y*zoom
                   end_if
                end_if
            next t            
        next e
    next passe
END_SUB
rem ============================================================================

rem ====================================================================================
rem                           Fishs
rem      Ported from https://www.freebasic.net/forum/viewtopic.php?f=7&t=28898 by UEZ
rem                  By Papydall build 02 / 11 / 2020
rem ===================================================================================
Dim  w , h , w2 , h2 , q,  i, j, l , p , a, m, x, y, t

w = 500+300 : h = 280 : w2 = w \ 2 : h2 = h \ 2 : l = 2000 : p = l * 0.6
mode 3,"Fishs ... Une touche pour sortir ...",w,h
paper  &hFFC2DFFF
repeat
   cls
   For j = l To 0 Step -1
      a = j / p
      m = t * 3 + a
      x = w2 + 50 + 9 * Sin(a) * Sin(j) + 60 * Sin(m)
      y = h2 + 50 * (Sin(-a * 5) + 1) * Cos(j)
      q = (j And 128) - Cos(j)^2 * 119
      plot x, y : draw x + 4, y + 12, Rgba(q - 10, q - 5, q Shl 1, &h80)
      x = x - 150
      plot x, y : draw x + 4, y + 12, Rgba(255, q, q, &h80)
      x = x - 150
      plot x, y : draw x + 4, y + 12, Rgba(q, 255, q, &h80)
      x = x + 450
      plot x, y : draw x + 4, y + 12, Rgba(255, 255-q, 255, &h80)

      t = t + 0.000005
   Next
   sleep 10
   Until Len(Inkey())

rem ===============================================================================
rem                          Fractal Forest
rem ===============================================================================


def w =  900
def h =  600
def deg2rad =  0.01745329251994329576923690768489
def c1      =  27
def c2      =  6
def c3      =  3

dim mColores%(19)
dim miColor%(10)

mode 3, "Fractal Forest" ,w, h
paper rgb(100,200,200) : cls

Initialisation
FractalTree(w \ 2  , h-1    ,270 , int(10*h\25))
FractalTree(w \ 10 , h\2   , 270 , int(5*h\25))
FractalTree(w \ 3  , h\4   , 270 , int(4*h\25))
FractalTree(w \ 8  , h-100 , 270 , int(4*h\25))
FractalTree(w -200 , h-50  , 270 , int(6*h\25))
FractalTree(w -100 , h-300 , 270 , int(3*h\25))
FractalTree(w -250 , h-400 , 270 , int(4*h\25))
FractalTree(w -600 , h\2   , 270 , int(4*h\25))

while inkey() = "" : wend
rem ===============================================================================
sub Initialisation()
    dim  i%
    mColores(0) = 2
    for i = 1 to 19
        mColores(i) = 6
        if i = 1 Or i = 2 then mColores(i) = 10
        if i >= 3 And i <= 6 then mColores(i) = 8
    next i
    miColor(2) = 3190051 : miColor(6) = 4136203 : miColor(8) = 1144621 : miColor(10) = 10289032
  
end_sub
rem ==================================================================================
sub FractalTree (x%, y%, angle%, lon%)
  dim  x1%, y1%, i%, p%, a1%, c%
  if lon >= 5 then
    x1 = x + lon * cos(angle*deg2rad)
    y1 = y + lon * sin(angle*deg2rad)
    if lon > 95 then p = 95 else p = lon
    i = mColores(p\5)
    if int(rnd() * 2) = 0 Then
      if i = mColores(0) Then
        i = mColores(1)
      elseif i = mColores(1) then
        i = mColores(0)
      End_If
    End_If
    c = miColor(i)
    if i = mColores(0) Or i = mColores(1) then
      for i = 0 to c3
        move  x + i - c3 \ 2, h-y : draw x1,h- y1  , c
      next i
    else
      for i = 0 to p\c2
        move x + i - p \ (c2*2),h- y : draw x1,h- y1 , c
      next i
    end_if
    for i = 0 to 3 - int(rnd()*3)
      p = int(rnd()*(lon - lon\6)) + lon\6
      a1 = angle - int(rnd()*55)
      x1 = x + p * cos(angle*deg2rad) : y1 = y + p * sin(angle*deg2rad)
      if lon > 100 then
        FractalTree (x1, y1, a1, 100-(int(rnd()*15))-c1+int(rnd()*c1))
      else
        FractalTree (x1, y1, a1, lon-(int(rnd()*15))-c1+int(rnd()*c1))
      end_if
      p = int(rnd() * (lon-lon \ 6)) + lon \ 6
      a1 = angle + int(rnd() * 55)
      x1 = x + p * cos(angle*deg2rad) : y1 = y + p * sin(angle*deg2rad)
      if lon > 100 then
        FractalTree (x1, y1, a1, 100-(int(rnd()*15))-c1+int(rnd()*c1))
      else
        FractalTree (x1, y1, a1, lon-(int(rnd()*15))-c1+int(rnd()*c1))
      end_if
    next i
  end_if
end_sub
rem ==========================================================================

rem ===============================================================================
rem                      GENERATEUR DE NUAGES
rem                  Par Papydall le 09 / 11 / 2020
rem               Adaptation de Free Basic à Crocodile Basic                
rem Ref : https://www.freebasic.net/forum/viewtopic.php?f=7&t=13842
rem ===============================================================================
const w     = 800  ' largeur de la fenetre
const h     = 600  ' hauteur de la fenetre
const zoom  = 128  ' facteur du zoom (essayer d'autres valeurs pour voir)

Dim noise(w, h)    ' the noise array
Dim texture(w, h)  ' texture array
Dim pal%(256)      ' color palette
Dim ch$  
dim x,y            

mode 3,"GENERATEUR DE NUAGES  ... <ESPACE> POUR REGENERER ... <ESC> POUR SORTIR ...",w, h

MakePalette(255, 255, 255, 0, 0, 255)
GenerateNoise
BuildTexture
Drawtexture

repeat
    ch = InKey
    If ch = Chr(32) Then
     GenerateNoise
     BuildTexture
     Drawtexture
    End_If  
Until ch = "ESCAPE"

rem ===============================================================================
' white to blue palette to simulate clouds.
Sub MakePalette(sr%, sg%, sb%, er%, eg%, eb%)
    Dim i%
    Dim iStart%(3)
    Dim iEnd%(3)
    Dim iShow%(3)
    Dim Rend(3)
    Dim InterPol(3)
  
    InterPol(0) = Ubound(pal)
    iStart(1) = sr
    iStart(2) = sg
    iStart(3) = sb
    iEnd(1) = er
    iEnd(2) = eg
    iEnd(3) = eb
    InterPol(1) = (iStart(1) - iEnd(1)) / InterPol(0)
    InterPol(2) = (iStart(2) - iEnd(2)) / InterPol(0)
    InterPol(3) = (iStart(3) - iEnd(3)) / InterPol(0)      
    Rend(1) = iStart(1)
    Rend(2) = iStart(2)
    Rend(3) = iStart(3)  
  
    For i = lbound(pal) To Ubound(pal)
        iShow(1) = Rend(1)
        iShow(2) = Rend(2)
        iShow(3) = Rend(3)

        pal(i) = Rgb(iShow(1),iShow(2),iShow(3))

        Rend(1) = Rend(1) - InterPol(1)
        Rend(2) = Rend(2) - InterPol(2)
        Rend(3) = Rend(3) - InterPol(3)
    Next i
  
End_Sub
rem ===============================================================================

'Generates random noise.
Sub GenerateNoise()
   For x  = 0 To w - 1
      For y  = 0 To h - 1
        noise(x, y) = Rnd()
      Next
   Next
End_Sub
rem ================================================================================
Function smoothNoise(x, y)

   'get fractional part of x and y
   Dim fractX
   Dim fractY
  
   'wrap around
   Dim x1%  
   Dim y1%
  
   'neighbor values
   Dim x2%
   Dim y2%

   'smooth the noise with bilinear interpolation
   Dim value

   fractX = x - Int(x)
   fractY = y - Int(y)
   x1%    = (Int(x) + w) Mod w
   y1%    = (Int(y) + h) Mod h
   x2%    = (x1 + w - 1) Mod w
   y2%    = (y1 + h - 1) Mod h
   value  = 0.0
   value  = Value + fractX       * fractY       * noise(x1, y1)
   value  = Value + fractX       * (1 - fractY) * noise(x1, y2)
   value  = Value + (1 - fractX) * fractY       * noise(x2, y1)
   value  = Value + (1 - fractX) * (1 - fractY) * noise(x2, y2)

   Return value
End_Function
rem ===============================================================================
Function Turbulence(xp, yp , size )
   Dim  value , initialSize  
   value = 0
   initialSize = size
   While size >= 1
      value = Value + SmoothNoise(xp / size, yp / size) * size
      size = size / 2
   wend  
   return (128 * value / initialSize)
  
End_Function
rem ===============================================================================
'Builds the texture.
Sub BuildTexture()
  
   For x  = 0 To w - 1
      For y  = 0 To h - 1
         texture(x, y) = Turbulence(x, y, zoom)
      Next y
   Next x
  
End_Sub
rem ===============================================================================
'Draws texture to screen.
Sub Drawtexture()
   ScreenLock
   Cls  
   For x  = 0 To w - 1
      For y  = 0 To h - 1
         plot x, y , pal(texture(x, y))
      Next y
   Next x
   ScreenUnLock
End_Sub
rem ===============================================================================

rem =============================================
rem       Mandel
rem =============================================

dim ix,iy,cr,ci,znr,zni,zor,zoi,k
mode 3,"Mandel ",800,600

FOR ix = 1 TO 800
    FOR iy = 1 TO 600
        cr = ix / 8000 - .68
        ci = iy / 3000 - .5
        WHILE (ABS(zoi) - ABS(ci) + ABS(zor) - ABS(cr) < 25) AND k < 128
            znr = zor * zor - zoi * zoi + cr
            zni = 2 * zoi * zor + ci
            zor = znr
            zoi = zni
            k = k + 1
        WEND
        IF k < 8 THEN k = 1
        WHILE k > 16
              k = k - 16
        WEND
        plot ix, 600-iy,rgb( k *10,20*k,k*50)
        zoi = 0
        zor = 0
        k = 0
    NEXT iy
NEXT ix

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

rem ==============================================================================
rem                   Mandelbrot set
rem ==============================================================================




dim mapping%(15)
Dim w, h
dim r_squared, i_squared, real_part, im_part, im0, real0, module_squared
dim real_start, real_end, im_start, im_end
dim dx, dy
dim x%, y%, k%, is_mandelbrot%, iterations%, color_index%
w = 800 : h = 600

mode 3,"Mandelbrot Set",w,h

mapping( 0) = Rgb(066 , 030 , 015) : rem brown 3
mapping( 1) = Rgb(025 , 007 , 026) : rem dark violette
mapping( 2) = Rgb(009 , 001 , 047) : rem darkest blue
mapping( 3) = Rgb(004 , 004 , 073) : rem blue5
mapping( 4) = Rgb(000 , 007 , 100) : rem blue4
mapping( 5) = Rgb(012 , 044 , 138) : rem blue3
mapping( 6) = Rgb(024 , 082 , 177) : rem blue2
mapping( 7) = Rgb(057 , 125 , 209) : rem blue1
mapping(  = Rgb(134 , 181 , 229) : rem blue0
mapping( 9) = Rgb(211 , 236 , 248) : rem lightest blue
mapping(10) = Rgb(241 , 233 , 191) : rem lightest yellow
mapping(11) = Rgb(248 , 201 , 095) : rem light yellow
mapping(12) = Rgb(255 , 170 , 000) : rem dirty yellow
mapping(13) = Rgb(204 , 128 , 000) : rem brown 0
mapping(14) = Rgb(153 , 087 , 000) : rem brown 1
mapping(15) = Rgb(106 , 052 , 003) : rem brown 2


real_start = -2.0
real_end = 0.5
im_start = -1.1
im_end = 1.1

dx = (real_end-real_start)/w
dy = (im_end-im_start)/h

for y = 0 to (h-1)/2
    im0 = im_start + y * dy
    for x = 0 to (w-1)
        is_mandelbrot = 1
        real0 = real_start + x * dx
        real_part = 0 : im_part = 0 : r_squared = 0 : i_squared = 0
        for k = 1 to 250
            r_squared = real_part^2 - im_part^2
            i_squared = 2 * real_part * im_part
            real_part = r_squared + real0  
            im_part = i_squared + im0

            module_squared = real_part ^ 2 + im_part^2
            if module_squared > 4 then is_mandelbrot = 0: iterations = k : exit_for
        next k
        color_index = iterations mod 16
        if is_mandelbrot = 0 then  pen mapping(color_index) : plot x,y : plot x,h-y
        if is_mandelbrot = 1 then  pen rgb(0,0,0) :  plot x,y :  plot x,h-y
    next x
next y
' ===================================================================================

repeat : until len(inkey())

rem =============================================================================
rem                                Spiral of Fire
rem Ported from https://www.freebasic.net/forum/viewtopic.php?f=7&t=28898 by UEZ
rem                to Crocodile Basic by Papydall build 01 / 11 / 2020
rem =============================================================================
dim px,py,sx,sy,b,c,i,t
dim w,w2,h,h2
w = 1600 : h = 900 : w2 = w shr 1 : h2 = h shr 1 : t = 0

mode 3,"Spiral of Fire ... Une touche pour sortir ...",w,h :' origin 0,h

repeat
   If py < h Then
      For i = 2e3 - 1 To 0 Step -1
         b = R(i / w, t / 28 - 0.1,0) ^ 1.6
         px = i
         py = t * 60
         move px, h-py : draw px + 1,h-( py + Min(b, h)), Rgb(Min(b, 255), Min(b / 6, 255), 0)    
         t = t + 0.00001
      Next
   End_if
  
Until Len(Inkey())
rem =============================================================================
Function R(x , y , n )
   If x * x > 4 Then Return n
   Return R(2 * x * y - 0.7, Tan(y * y - x * x), n + 1)
End Function
rem =============================================================================

rem ================================================================
rem                  Swirl
rem           Adaptation de Papydall
rem  Code origine de D.J.Peters en Free Basic
rem  http://mathworld.wolfram.com/Swirl.html
rem ===============================================================

'dim i%
'for i = 0 to 255
' palette i,0,0,i
'next
dim  w%,h%
w = 800 : h = 600
mode 3,"SWIRL", w,h
screenset 1,0

dim  cx ,cy , a,t,x,y,dx,dy,r,f,couleur
dim  frames%
dim  o%
dim  n

cx = w/2 : cy = h/2
while inkey() = ""
   o = 1  + (frames mod 10)
   n = 80 + cos(a)*70
   a = a  + 0.05

  For y = 0 To w - 1
      dy = (y - cy)/n
      For x  = 0 To w-1
          dx = (x - cx)/n
          r  = Sqr(dx * dx + dy*dy)
          If dx = 0 And  dy = 0 Then
             t = 0
          Else
             t = Atan2(dy, dx)
          End_If
      
         f = Sin(6 * Cos(r) - o*t)
         couleur = 128 + 127 * f
     '    couleur =  64 + 127 * f
     '    couleur =  32 + 255 * f
         Plot x, y, couleur
      Next x
   Next y
   flip
   frames = frames + 1
wend
rem =================================================================================

rem *=====================================================================================*
rem *                             Wonky Spiral                                            *
rem *    Ported from https://www.freebasic.net/forum/viewtopic.php?f=7&t=28898 by UEZ     *
rem *                     by Papydall build 02 / 11 / 2020                                *
rem *=====================================================================================*
 
Dim  w , h , w2 , h2
Dim  x,y,a,f1,f2,r,t
'  Directive DEF :  Plus rapide qu'une FUNCTION semble-t-il ?
def Hypot(a, b) = (Sqr(a * a + b * b))

w = 400 : h = 300 : w2 = w shr 1  : h2 = h shr 1

mode 3,"Wonky Spiral ... Une touche pour sortir ...",w,h
repeat  
    For x = w - 1 To 0 Step -1
      For y = h - 1 To 0 Step -1
         f1 = x - w2 : f2 = y - h2 : a = Atan2(f1, f2)
         r = 128 - Sin((a + Sin(Hypot(f1, f2) / -26 + t)) * 5) * 128
         Plot x, y, Rgba(Min(x, 255), Min(r, 255), 0, &hFF)
         t = t + 0.000001 : ' <<<< adapter cette valeur selon votre ordi
      Next
   Next  
Until Len(Inkey())
rem =======================================================================================

rem *==================================================================**
rem *                         Sequoia Wood                              *
rem *            Apadtation de Papydall en Crocodile Basic              *
rem *                      Le 01 / 11 / 2020                            *            
rem *       Code origine sur le forum Free Basic : Auteur UEZ           *
rem *   Ref : https://www.freebasic.net/forum/viewtopic.php?f=7&t=28898 *
rem *==================================================================**

dim w,h,px,py,b, i,j,k,t
w = 1600  : h = 900  : '  <<<<<<<<<<<<<<<<  choisissez des valeurs >= aux dimensions de votre ordi
mode 3,"Sequoia Wood .... Une touche pour quitter ...",w,h
j = 16
repeat
   For i = h  To 0 Step -1
      b = t / j
      For k = j To 0 Step -4 : ' <<<< modifier ce step pour voir
         If b > 0 Then
            px = (t * 200) Mod w
            move px, i : draw  px + 40, i + 1, Rgba(Min(255, b * 120), Min(255, b * b * 14),9, 26)
         End_if
         b = Cos(i / 1e3 + b * Cos(b * b / 2) + 4) * b - 2.8
         t = t + 0.0000008 : ' <<<< modifier ce dernier chiffre (entre 1 et 9) pour ajuster la vitesse du tracé selon votre ordi
      Next k  
   Next i
until len(inkey())  
rem =====================================================================

rem ============================================================================
rem                    Tourne, Tourne, Tourne Encore
rem                    Par Papydall le 13 / 11 / 2020
rem ============================================================================
const deg2rad = pi / 180
dim w%,h%,xc%,yc%,t$
w = 800 : h = 600
xc = w/2 : yc = h/2

mode 3,"Tourne, tourne, tourne encore",w,h
' ------------------------------------------------------------------------------
Tourne(xc,yc,100,3,60,68,40,3)
' ------------------------------------------------------------------------------
end
rem ============================================================================
SUB Tourne(x0%,y0%,r1,f1,r2,f2,r3,f3)
    dim t, x1,y1,x2,y2,x3,y3,xd,yd
    
    arc x0,y0,12
    for t = 0 to 360 step .025
        x1 = x0 + R1*cos(f1*t*deg2rad) : y1 = y0 + R1*sin(f1*t*deg2rad)
        x2 = x1 + R2*cos(f2*t*deg2rad) : y2 = y1 + R2*sin(f2*t*deg2rad)
        x3 = x2 + R3*cos(f3*t*deg2rad) : y3 = y2 + R3*sin(f3*t*deg2rad)
        pen rgb(255,000,000) : arc x1,y1,1'5
        pen rgb(000,255,000) : arc x2,y2,1
        pen rgb(255,255,000) : arc x3,y3,1
       sleep 1 'pour suive le tracé
    next t
    while inkey() = ""
        move xc,yc : fill rgb(255,0,0) : sleep 1000
        move xc,yc : fill rgb(0,255,0) : sleep 1000
        move xc,yc : fill rgb(0,0,255) : sleep 1000
    wend

END_SUB
rem ============================================================================

rem =========================================================================
rem                        ESTHETIQUE POLAIRE PAR PAPYDALL
rem =========================================================================
dim xc1,yc1,xc2,yc2,xc3,yc3,xc4,yc4,xc5,yc5,r,rsur2,a,x,y,p,c$
p = pi/360

mode 3,"ESTHETIQUE POLAIRE PAR PAPYDALL",1000,400

xc1 = 100 : yc1 = 200
xc2 = 3*xc1+10 : yc2 = yc1
xc3 = 5*xc1+20 : yc3 = yc1
xc4 = 7*xc1+20 : yc4 = yc1
xc5 = 9*xc1+20 : yc5 = yc1

for r = 1 to xc1  
    rsur2 = r / 2
    for a = 0 to 2*pi step p
        x = rsur2 * (1-cos(a)) * cos(a) : y = rsur2 * (1-cos(a)) * sin(a)
        pen rgb( (abs(a*180/pi+x) mod 255),(abs(a*180/pi-r) mod 255), (abs(r-y) mod 255))
        plot xc1+x,yc1-y : plot xc1-x,yc1-y
 ' -----------------------------------------------------------------------------
        x = rsur2 * (1+cos(a)) * cos(a) : y = rsur2 * (1-cos(a)) * sin(a)
        plot xc2+x,yc2-y : plot xc2-x,yc2-y
 ' -----------------------------------------------------------------------------
        x = rsur2 * (1+cos(a)) * cos(a) : y = rsur2 * (1-sin(a)) * sin(a)
        plot xc3+x,yc3-y : plot xc3-x,yc3-y
 ' -----------------------------------------------------------------------------
        x = rsur2* (1-cos(a)) * cos(a) : y = rsur2 * (1-cos(a)) * sin(r*p)
        plot xc4+x,yc4-y : plot xc4-x,yc4-y
        plot xc4+x,yc4+y : plot xc4-x,yc4+y
 ' -----------------------------------------------------------------------------
        x = rsur2* (1-cos(a)) * sin(a) : y = rsur2 * (1-sin(a)) * sin(a)
        plot xc5+x,yc5-y : plot xc5-x,yc5-y
 ' -----------------------------------------------------------------------------
    next a
next r

while inkey$() = "" : wend