GS - La spirale d'Ulam a été créée en 1963 par le mathématicien Stanislaw Ulam durant une conférence scientifique alors qu'il s'ennuyait. Il décida de disposer des entiers sur une grille carrée selon une spirale et il marqua les nombres premiers. Certains nombres premiers semblent dessiner des motifs qui n'ont rien d'aléatoires ou qui suivent des lignes droites.
Il a publié deux articles à propos de sa découverte: - S.M. Ulam, M.L. Stein and M.B. Wells, A Visual Display of Some Properties of the Distribution of Primes, American Mathematical Monthly (71), pp516-520, 1964 et - S.M. Ulam and M.L. Stein, An Observation on the Distribution of Primes, American Mathematical Monthly (74), pp43-44, 1967.
En 1988, Jean-François Colonna de l'Ecole Polytechnique a généralisé cette spiral. Au lieu de marquer seulement les nombres premiers, il a représenté tous les entiers selon une table de couleur en correspondance avec leur nombre de diviseurs.
Si on représente seulement les entiers avec un nombre impair de diviseurs (non fait ici), ils sont tous des carrés parfaits et appartiennent tous à la même diagonale. Il y a donc plus d'entiers avec un nombre pair de diviseurs qu'avec un nombre impair.
# spiral.tcl
# Author: Gerard Sookahet
# Date: 03 May 2004
# Description: Ulam spiral and divisor spiral on a square grid
package require Tk
proc SpiralMain { N } {
set w .sp
catch {destroy $w}
toplevel $w
wm withdraw .
wm title $w "Spiral number"
wm geometry $w +100+10
set dim [expr {int(sqrt($N) + 10)}]
set mid [expr {$dim/2}]
pack [canvas $w.c -width $dim -height $dim -bg white]
set f1 [frame $w.f1 -relief sunken -borderwidth 2]
pack $f1 -fill x
button $f1.bu -text Ulam -width 6 -bg blue -fg white \
-command "PlotUlam $w $N $mid"
button $f1.bd -text Divisor -width 6 -bg blue -fg white \
-command "PlotDivisor $w $N $mid"
button $f1.bq -text Quit -width 5 -bg blue -fg white -command exit
eval pack [winfo children $f1] -side left
}
proc PlotUlam { w N mid } {
$w.c delete all
set pix [image create photo]
$w.c create image 0 0 -anchor nw -image $pix
set cmap #030303
set i $mid
set j $mid
set n 1
set m 1
set M [expr {int(sqrt($N))}]
while {$m < $M} {
for {set k 1} {$k <= $m} {incr k} {
incr n
incr i
if [IsPrime $n] {$pix put $cmap -to $i $j}
}
for {set k 1} {$k <= $m} {incr k} {
incr n
incr j -1
if [IsPrime $n] {$pix put $cmap -to $i $j}
}
set mm [expr {$m + 1}]
for {set k 1} {$k <= $mm} {incr k} {
incr n
incr i -1
if [IsPrime $n] {$pix put $cmap -to $i $j}
}
for {set k 1} {$k <= $mm} {incr k} {
incr n
incr j
if [IsPrime $n] {$pix put $cmap -to $i $j}
}
update idletasks
incr m 2
}
}
proc PlotDivisor { w N mid } {
$w.c delete all
set pix [image create photo]
$w.c create image 0 0 -anchor nw -image $pix
set cmap #030303
set i $mid
set j $mid
# Spiral initialization by hand for 1 2 3 4 5 6 7
$pix put $cmap -to $i $j
incr i
$pix put $cmap -to $i $j
incr j -1
$pix put $cmap -to $i $j
incr i -1
$pix put [colormap 1] -to $i $j
incr i -1
$pix put $cmap -to $i $j
incr j
$pix put [colormap 2] -to $i $j
incr j
$pix put $cmap -to $i $j
set n 7
set m 3
set M [expr {int(sqrt($N))}]
while {$m < $M} {
for {set k 1} {$k <= $m} {incr k} {
incr n
incr i
$pix put [colormap [NbDivisor $n]] -to $i $j
}
for {set k 1} {$k <= $m} {incr k} {
incr n
incr j -1
$pix put [colormap [NbDivisor $n]] -to $i $j
}
set mm [expr {$m + 1}]
for {set k 1} {$k <= $mm} {incr k} {
incr n
incr i -1
$pix put [colormap [NbDivisor $n]] -to $i $j
}
for {set k 1} {$k <= $mm} {incr k} {
incr n
incr j
$pix put [colormap [NbDivisor $n]] -to $i $j
}
update idletasks
incr m 2
}
}
# Primality testing
proc IsPrime { n } {
if {$n==1} {return 0}
set max [expr {int(sqrt($n))}]
set d 2
while {$d <= $max} {
if {$n%$d == 0} {return 0}
incr d
}
return 1
}
# Return the number of divisors of an integer
proc NbDivisor { n } {
set max [expr {int(sqrt($n))}]
set nd 0
for {set i 2} {$i <= $max} {incr i} {
if {$n%$i == 0} {incr nd}
}
return $nd
}
# Arbitrary color table
proc colormap { n } {
set lcolor {#030303 #CD0000 #CD4F39 #EE4000 #EE6A50 #FF7F00 #EE9A00 \
#FF8C69 #FFC125 #EEEE00 #EED5B7 #D2691E #BDB76B #00FFFF \
#7FFFD4 #FFEFD5 #AB82FF #E066FF
}
return [lindex $lcolor $n]
}
# The maximum integer. The canvas is sized from its square root
SpiralMain 70000David Cobac : en remplaçant n=7 par n=41 dans la procédure PlotUlam on peut observer une particularité (cf. une formule découverte par Euler fournissant beaucoup de nombres premiers : n²+n+41).
Je me demande pourquoi initialiser la spirale pour n=1 à n=7 ?
On pourrait aussi parler de test de primalité mais là je sors du sujet ;))
GS L'initialisation, c'était juste pour faire l'économie des boucles for qui vont de 1 à 1. C'est sûr que un tour de spiral ce n'est pas une grosse économie ;-)
David Cobac Certes mais on ne peut pas commencer à 41 facilement. Je propose donc de commenter toute la partie d'initialisation et de mettre :
set n 1 set m 1
ce qui permet maintenant de commencer facilement à n'importe quel nombre entier dont 41 :) Avec un petit détail dans la procédure IsPrime à ajouter au début puisque 1 n'est pas premier :
if {$n==1} {return 0}En tout cas cette petite application est bien sympathique. Ça donne envie d'aller représenter aussi la conjecture de Collatz...
GS Ask, it shall be given !. Voilà, c'est fait, j'ai carrément enlevé l'initialisation manuelle.
La conjecture de Collatz (problème de Syracuse) doit être aussi intéressante. Je serais curieux de voir ce que cela donne. J'imagine que le code couleur correspond au nombre de pas nécessaires pour converger vers 1.
David Cobac : en modifiant ton script, j'ai le code ci-dessous pour les temps de vol. Maintenant on pourrait représenter autre chose, comme l'altitude maximale ou la durée de vol en altitude...
package require Tk
proc SpiralMain { N } {
set w .sp
catch {destroy $w}
toplevel $w
wm withdraw .
wm title $w "Collatz flight \" la Ulam\""
wm geometry $w +100+10
set dim [expr {int(sqrt($N) + 10)}]
set mid [expr {$dim/2}]
pack [canvas $w.c -width $dim -height $dim -bg white]
set f1 [frame $w.f1 -relief sunken -borderwidth 2]
pack $f1 -fill x
button $f1.bu -text Collatz -width 6 -bg blue -fg white \
-command "PlotFT $w $N $mid"
button $f1.bq -text Quit -width 5 -bg blue -fg white -command exit
eval pack [winfo children $f1] -side left
}
proc PlotFT { w N mid } {
$w.c delete all
set pix [image create photo]
$w.c create image 0 0 -anchor nw -image $pix
set i $mid
set j $mid
set n 1
set m 1
set M [expr {int(sqrt($N))}]
while {$m < $M} {
for {set k 1} {$k <= $m} {incr k} {
incr n
incr i
$pix put [colormap [collatz_flighttime $n]] -to $i $j
}
for {set k 1} {$k <= $m} {incr k} {
incr n
incr j -1
$pix put [colormap [collatz_flighttime $n]] -to $i $j
}
set mm [expr {$m + 1}]
for {set k 1} {$k <= $mm} {incr k} {
incr n
incr i -1
$pix put [colormap [collatz_flighttime $n]] -to $i $j
}
for {set k 1} {$k <= $mm} {incr k} {
incr n
incr j
$pix put [colormap [collatz_flighttime $n]] -to $i $j
}
update idletasks
incr m 2
}
}
proc collatz_flighttime { n } {
set t 0
while {$n!=1} {
set n [expr {$n%2==0?$n/2:3*$n+1}]
incr t
}
return $t
}
proc colormap { time } {
# les grandes dures de vol => en rouge
if {$time>=256} {return red}
# les autres en niveaux de gris
set h [format %02x [expr {255 - $time}]]
return #[string repeat $h 3]
}
# The maximum integer. The canvas is sized from its square root
SpiralMain 70000