Tetraèdre avec 3dcanvas

 

GS - Cette petite démo utilise le widget 3dcanvas [1] pour dessiner un tétraèdre de Sierpinksi. On part d'un tétraèdre que l'on remplace par 4 tétraèdres en contact et dont la longueur est la moitié de la longueur des côtés du précédent. Ensuite on réitère le processus pour les nouveaux tétraèdres.

  La librairie 3dcanvas pour Tcl8.4.x est disponible sous:

  - Linux [http://gersoo.free.fr/inform/tcl/3dcanvas/dddcanvas10.so]

  - Windows [http://gersoo.free.fr/inform/tcl/3dcanvas/dddcanvas10.dll] (compilé par EB)

 # tetra-3dc.tcl
 # Author: Gerard Sookahet
 # Date: 2004-06-18
 # Description: 3D Sierpinski Tetrahedron with 3dcanvas

 package require Tk
 load ./dddcanvas10[info sharedlibextension]

 bind all <Escape> { exit }

 proc About {} {
  set w .about
  catch {destroy $w} ; toplevel $w
  wm title $w "About this demo"
  message $w.msg -justify center -aspect 250 -relief sunken \
         -text "3dcanvas demo: Sierpinski Tetrahedron\n\nGerard Sookahet\n\nJune 2004"
  button $w.bquit -text OK -command {destroy .about}
  eval pack [winfo children $w]
 }

 # Animation loop
 proc Animate {} {
     global G
  .c phirot $G 3
  .c thetarot $G 3
  after 32 Animate
 }

 proc Sierpinski { w level l } {
     global rdepth
  if {$level > $rdepth} then return
  set i 1
  foreach {x y z} $l {
	 set p($i) "$x $y $z"
	 incr i
  }
  set p12 [MidPoint [concat $p(1) $p(2)]]
  set p13 [MidPoint [concat $p(1) $p(3)]]
  set p14 [MidPoint [concat $p(1) $p(4)]]
  set p23 [MidPoint [concat $p(2) $p(3)]]
  set p24 [MidPoint [concat $p(2) $p(4)]]
  set p34 [MidPoint [concat $p(3) $p(4)]]
  incr level
  if {$level == $rdepth} then {
    DrawTetra $w [concat $p(1) $p(2) $p(3) $p(4)]
  }
  Sierpinski $w $level [concat $p(1) $p12 $p13 $p14]
  Sierpinski $w $level [concat $p(2) $p12 $p23 $p24]
  Sierpinski $w $level [concat $p(3) $p13 $p23 $p34]
  Sierpinski $w $level [concat $p(4) $p14 $p24 $p34]
 }

 proc DrawTetra { w l } {
     global G
  set i 1
  foreach {x y z} $l {
	 set p($i) "$x $y $z"
	 incr i
  }
  $w addgroup $G items [eval $w create polygon [join [concat $p(1) $p(2) $p(3)] " "] -fill red]
  $w addgroup $G items [eval $w create polygon [join [concat $p(2) $p(3) $p(4)] " "] -fill yellow]
  $w addgroup $G items [eval $w create polygon [join [concat $p(1) $p(3) $p(4)] " "] -fill blue]
  $w addgroup $G items [eval $w create polygon [join [concat $p(1) $p(2) $p(4)] " "] -fill green]

 }

 # Return the middle coordinates of two 3d points
 proc MidPoint { l } {
  set X 0
  set Y 0
  set Z 0
  foreach {x y z} $l {
         set X [expr {$X + $x}]
         set Y [expr {$Y + $y}]
         set Z [expr {$Z + $z}]
  }
  return [list [expr {$X/2}] [expr {$Y/2}] [expr {$Z/2}]]
 }

 proc Init { w } {
     global G
  $w delete all
  set G [.c create group]

  set edge 340
  set x1 [expr {sqrt(3)*$edge/3}]
  set x2 [expr {sqrt(3)*$edge/6}]
  set z3 [expr {sqrt(6)*$edge/3}]
  set y2 [expr {$edge/2}]
  # Vertices' coordinates of the regular tetrahedron
  set p1 "$x1 0 0"
  set p2 "-$x2 $y2 0"
  set p3 "-$x2 -$y2 0"
  set p4 "0 0 $z3"

  Sierpinski $w 0 [concat $p1 $p2 $p3 $p4]
 }

 proc Main {} {
     global somega sphi stheta
     global vdist
     global rdepth

   set vdist 2400
   set rdepth 4

   wm title . "Sierpinski Tetrahedron"
   3dcanvas .c -bg black -width 500 -height 500
   pack .c -side top

   set f1 [frame .f1]
   label $f1.l1 -text "Recursive depth "
   spinbox $f1.sdepth -from 1 -to 7 -textvariable rdepth -width 4
   label $f1.l2 -text "   View distance "
   scale $f1.vd -from 4600 -to 1000 -length 210 -orient horiz -showvalue true \
                -variable vdist -command {.c configure -viewdistance}
   eval pack [winfo children $f1] -side left
   pack $f1
   set f2 [frame .f2]
   button $f2.brun -text "Run" -width 10 -fg white -bg blue -command {Init .c}
   button $f2.bromega -text "Omega rotate" -width 10 -command {.c omegarot $G 8}
   button $f2.brphi -text "Phi rotate" -width 10 -command {.c phirot $G 8}
   button $f2.brtheta -text "Theta rotate" -width 10 -command {.c thetarot $G 8}
   button $f2.banim -text Animate -width 10 -command {Animate}
   button $f2.babout -text A -width 1 -bg grey -command {About}
   button $f2.bquit -text Quit -width 10 -bg grey -command exit
   eval pack [winfo children $f2] -side left
   pack $f2
 }

 Main

David Cobac : Très joli !

J'ai modifié le script proposé en générant le tétraèdre de Sierpinski de manière aléatoire (un grand classique) plutôt que récursivement. Cela donne cela :

 package require Tk
 load ./dddcanvas10[info sharedlibextension]

 bind all <Escape> { exit }

 proc About {} {
  set w .about
  catch {destroy $w} ; toplevel $w
  wm title $w "About this demo"
  message $w.msg -justify center -aspect 250 -relief sunken \
         -text "3dcanvas demo: Random Sierpinski Tetrahedron\n\nGerard Sookahet\n\
 modified by David Cobac\n\nJune 2004"
  button $w.bquit -text OK -command {destroy .about}
  eval pack [winfo children $w]
 }

 # Animation loop
 proc Animate {} {
     global G
  .c phirot $G 3
  .c thetarot $G 3
  after 32 Animate
 }

 proc S2 {w l} {
    global G rdepth
    set i 1
    foreach {x y z} $l {
	set p($i) "$x $y $z"
	incr i
    }
    # le point de dpart
    set pt $p([expr {int(rand()*4+1)}])
    for {set i 1} {$i<=$rdepth} {incr i} {
	# on calcule le nouveau point
	set r [expr {int(rand()*4+1)}]
	set pt [MidPoint [concat $pt $p($r)]]
	# on ajoute de la couleur
	set nivo [expr {$i*255/$rdepth}]
	set coul [format #%02x00ff $nivo]
	# on trace
	$w addgroup $G items [$w create sphere 1 -tags yo$i -fill $coul]
	eval $w translate yo$i $pt
    }
 }

 # Return the middle coordinates of two 3d points
 proc MidPoint { l } {
  set X 0
  set Y 0
  set Z 0
  foreach {x y z} $l {
         set X [expr {$X + $x}]
         set Y [expr {$Y + $y}]
         set Z [expr {$Z + $z}]
  }
  return [list [expr {$X/2}] [expr {$Y/2}] [expr {$Z/2}]]
 }

 proc Init { w } {
     global G
  $w delete all
  set G [.c create group]

  set edge 340
  set x1 [expr {sqrt(3)*$edge/3}]
  set x2 [expr {sqrt(3)*$edge/6}]
  set z3 [expr {sqrt(6)*$edge/3}]
  set y2 [expr {$edge/2}]
  # Vertices' coordinates of the regular tetrahedron
  set p1 "$x1 0 0"
  set p2 "-$x2 $y2 0"
  set p3 "-$x2 -$y2 0"
  set p4 "0 0 $z3"

  S2 $w [concat $p1 $p2 $p3 $p4]
 }

 proc Main {} {
     global somega sphi stheta
     global vdist
     global rdepth

   set vdist 2400
   set rdepth 1000

   wm title . "Sierpinski Tetrahedron"
   3dcanvas .c -bg black -width 500 -height 500
   pack .c -side top

   set f1 [frame .f1]
   label $f1.l1 -text "Random depth "
   spinbox $f1.sdepth -from 1 -to 5000 -textvariable rdepth -width 4
   label $f1.l2 -text "   View distance "
   scale $f1.vd -from 4600 -to 1000 -length 210 -orient horiz -showvalue true \
                -variable vdist -command {.c configure -viewdistance}
   eval pack [winfo children $f1] -side left
   pack $f1
   set f2 [frame .f2]
   button $f2.brun -text "Run" -width 10 -fg white -bg blue -command {Init .c}
   button $f2.bromega -text "Omega rotate" -width 10 -command {.c omegarot $G 8}
   button $f2.brphi -text "Phi rotate" -width 10 -command {.c phirot $G 8}
   button $f2.brtheta -text "Theta rotate" -width 10 -command {.c thetarot $G 8}
   button $f2.banim -text Animate -width 10 -command {Animate}
   button $f2.babout -text A -width 1 -bg grey -command {About}
   button $f2.bquit -text Quit -width 10 -bg grey -command exit
   eval pack [winfo children $f2] -side left
   pack $f2
 }

 Main

GS Je retourne le compliment: c'est superbe. Avec la version aléatoire, on se croirait dans l'espace.


Contribution de FW [2]: Ajouter ce code à la fin pour faire tourner l'objet avec la souris.

 proc handleRot {x y win} {
   global cx cy G
   $win phirot $G [expr {180 * (double($x - $cx) / [winfo width $win])}]
   $win thetarot $G [expr {180 * (double($y - $cy) / [winfo height $win])}]

   set cx $x
   set cy $y
 }

 bind .c <1> {set cx %x; set cy %y}
 bind .c <B1-Motion> {handleRot %x %y %W}

Catégorie Mathématiques