#rR gscope_fourmis.tcl sourcé par Fourmis dans gscope_atelier proc DrawFourmis {} { global TFB #LoadTkAndPackages # parametres if { ! [info exists TFB(step) ]} { set TFB(step) 5 } if { ! [info exists TFB(HueProche) ]} { set TFB(HueProche) 0.2 } if { ! [info exists TFB(lenFourmi) ]} { set TFB(lenFourmi) 1 } if { ! [info exists TFB(widFourmi) ]} { set TFB(widFourmi) 1 } if { ! [info exists TFB(headFourmi) ]} { set TFB(headFourmi) 1 } if { ! [info exists TFB(colTeteFourmi) ]} { set TFB(colTeteFourmi) white } if { ! [info exists TFB(colCorpsFourmi) ]} { set TFB(colCorpsFourmi) grey } if { ! [info exists TFB(nFourmis) ]} { set TFB(nFourmis) 5 } if { ! [info exists TFB(rad) ]} { set TFB(rad) 10 } if { ! [info exists TFB(nRouges) ]} { set TFB(nRouges) 30 } if { ! [info exists TFB(nJaunes) ]} { set TFB(nJaunes) 30 } if { ! [info exists TFB(nBleues) ]} { set TFB(nBleues) 20 } if { ! [info exists TFB(nArcEnCiel) ]} { set TFB(nArcEnCiel) 30 } if { ! [info exists TFB(dimX) ]} { set TFB(dimX) 1000 } if { ! [info exists TFB(dimY) ]} { set TFB(dimY) 1000 } if { ! [info exists TFB(mur) ]} { set TFB(mur) 1 } return [Plateau] } proc Boules PAD { return [BoulesTriColor $PAD] } proc MeetBall {iF bbox nbb} { return [MeetBallTriColor $iF $bbox $nbb] } proc BoulesArcEnCiel {PAD} { global TFB # trace les boules foreach i [NombresEntre 0 [expr $TFB(nArcEnCiel) - 1] ] { set Hue [expr 1.0*rand()] Espionne $Hue set col [Nuance $Hue 0. 1.] set ok 0 while {! $ok} { set x [expr {round($TFB(dimX)*rand())}] set y [expr {round($TFB(dimY)*rand())}] set x1 [expr {$x - $TFB(rad)}] set x2 [expr {$x + $TFB(rad)}] set y1 [expr {$y - $TFB(rad)}] set y2 [expr {$y + $TFB(rad)}] # test boule sur le plateau if {$x1 < $TFB(rad) || $y1 < $TFB(rad)} { continue } if {$x2 > ($TFB(dimX)-$TFB(rad)) || $y2 > ($TFB(dimY)-$TFB(rad))} { continue } # rajoute rad pour que les boules # soitent ecartees d'une boule set x1f [expr {$x - 2.*$TFB(rad)}] set x2f [expr {$x + 2.*$TFB(rad)}] set y1f [expr {$y - 2.*$TFB(rad)}] set y2f [expr {$y + 2.*$TFB(rad)}] if {[$PAD find overlapping $x1f $y1f $x2f $y2f] == {}} { set ok 1 } } $PAD create oval \ $x1 $y1 $x2 $y2 \ -fill $col \ -outline $col \ -tags [list ball $Hue libre] #puts "id $id $x1 $y1 $x2 $y2" } } proc BoulesTriColor {PAD} { global TFB # trace les boules foreach col {red yellow green} nBalls [list [set TFB(nRouges)] [set TFB(nJaunes)] [set TFB(nBleues)]] { for {set i 0} {$i < $nBalls} {incr i} { set ok 0 while { ! $ok} { set x [expr {round($TFB(dimX)*rand())}] set y [expr {round($TFB(dimY)*rand())}] set x1 [expr {$x - $TFB(rad)}] set x2 [expr {$x + $TFB(rad)}] set y1 [expr {$y - $TFB(rad)}] set y2 [expr {$y + $TFB(rad)}] # test boule sur le plateau if {$x1 < $TFB(rad) || $y1 < $TFB(rad)} { continue } if {$x2 > ($TFB(dimX)-$TFB(rad)) || $y2 > ($TFB(dimY)-$TFB(rad))} { continue } # rajoute rad pour que les boules # soient ecartees d'une boule set x1f [expr {$x - 2.*$TFB(rad)}] set x2f [expr {$x + 2.*$TFB(rad)}] set y1f [expr {$y - 2.*$TFB(rad)}] set y2f [expr {$y + 2.*$TFB(rad)}] if {[$PAD find overlapping $x1f $y1f $x2f $y2f] == {}} { set ok 1 } } $PAD create oval \ $x1 $y1 $x2 $y2 \ -fill $col \ -outline $col \ -tags [list ball $col libre] #puts "id $id $x1 $y1 $x2 $y2" } } } proc UnMur {PAD {Sens ""}} { global TFB if {$Sens=="Hori"} { set x1 [expr {0.1 * $TFB(dimX)}] set x2 [expr {0.3 * $TFB(dimX)}] set y1 [expr {10}] set y2 [expr {$y1 + 20}] } else { set x1 [expr {10}] set x2 [expr {$x1 + 20}] set y1 [expr {0.1 * $TFB(dimY)}] set y2 [expr {0.3 * $TFB(dimY)}] } return [$PAD create rectangle $x1 $y1 $x2 $y2 \ -fill grey \ -outline white \ -tags [list "mur"]] } proc Plateau {} { global PAD TFB global CouleurDuFondDeUnCanva set CouleurDuFondDeUnCanva "black" if {0} { set w .f frame $w grid $w -row 0 -column 0 -sticky news grid columnconfig $w 0 -weight 1 grid rowconfig $w 0 -weight 1 set PAD $w.can canvas $PAD \ -height $TFB(dimY) \ -width $TFB(dimX) \ -scrollregion [list 0 0 $TFB(dimX) $TFB(dimY)] \ -background black grid $PAD -row 0 -column 0 -sticky news FenetreAuCentre $w } set ::go 0 Espionne "$TFB(dimX) $TFB(dimY) $TFB(dimX) $TFB(dimY)" set PAD [UnCanva $TFB(dimX) $TFB(dimY) $TFB(dimX) $TFB(dimY)] MainLeveeSurUnCanva $PAD Espionne $PAD regsub "\.canvas" $PAD "" TopLev bind $TopLev "" GoNoGo BoutonneLaFenetre $TopLev "Pause" "GoNoGo" BoutonneLaFenetre $TopLev "Start" "StartFourmis" BoutonneLaFenetre $TopLev "Fourmis" "InitFourmis" BoutonneLaFenetre $TopLev "Boules" "Boules $PAD" BoutonneLaFenetre $TopLev "Mur Hori" "UnMur $PAD Hori" BoutonneLaFenetre $TopLev "Mur Vert" "UnMur $PAD Vert" return } proc BougeFourmi {} { set ::go [expr {! $::go}] update return } proc InitFourmis {} { global TFB PAD set taille [expr {($TFB(lenFourmi) + $TFB(headFourmi))/2}] for {set i 0} {$i < $TFB(nFourmis)} {incr i} { set ok 0 while {! $ok} { set x [expr {round($TFB(dimX)*rand())}] set y [expr {round($TFB(dimY)*rand())}] # y a t il qq chose dans la boite # qui va contenir la fourmi ? set x1 [expr {$x - $taille}] set x2 [expr {$x + $taille}] set y1 [expr {$y - $taille}] set y2 [expr {$y + $taille}] if {[$PAD find overlapping $x1 $y1 $x2 $y2] == {}} { set ok 1 } } if {1} { set x1 [expr {$x - $TFB(headFourmi)/2}] set x2 [expr {$x + $TFB(headFourmi)/2}] set y1 [expr {$y - $TFB(headFourmi)/2}] set y2 [expr {$y + $TFB(headFourmi)/2}] $PAD create oval \ $x1 $y1 $x2 $y2 \ -fill $TFB(colTeteFourmi) \ -outline $TFB(colTeteFourmi) \ -tags [list fourmi tete "F$i"] } else { set x1 [expr {$x - $TFB(lenFourmi)/2}] set x2 [expr {$x + $TFB(lenFourmi)/2}] set y1 [expr {$y - $TFB(widFourmi)/2}] set y2 [expr {$y + $TFB(widFourmi)/2}] $PAD create polygon \ $x1 $y1 $x1 $y2 $x2 $y2 $x2 $y1 \ -fill $TFB(colCorpsFourmi) \ -outline $TFB(colCorpsFourmi) \ -tags [list fourmi corps "F$i"] set xc $x2 ; set yc $y set x1 [expr {$xc - $TFB(headFourmi)/2}] set x2 [expr {$xc + $TFB(headFourmi)/2}] set y1 [expr {$yc - $TFB(headFourmi)/2}] set y2 [expr {$yc + $TFB(headFourmi)/2}] $PAD create polygon \ $x1 $y1 $x2 $yc $x1 $y2 \ -fill $TFB(colTeteFourmi) \ -outline $TFB(colTeteFourmi) \ -tags [list fourmi tete "F$i"] } set TFB(F$i,oldAng) 0 set TFB(F$i,angle) [BonAngle [expr {359.*rand()}]] set TFB(F$i,hasBall) 0 set TFB(F$i,lastBall) -1 set TFB(F$i,col) "" # set TFB(F$i,angle) 45. TourneFourmi "F$i" OnSortPas "F$i" lappend TFB(LFourmis) $i } return } proc GoNoGo {} { set ::go [expr {!$::go}] return $::go } proc StartFourmis {} { global TFB PAD set ::go 1 set iF "F0" #$PAD moveto $iF 300 300 set TFB(F0,angle) 45. #trace add variable TFB(F5,angle) write tangle # bounding box du mur lassign [$PAD bbox "mur"] x1m y1m x2m y2m set Step 0 while {$::go} { if {0 && [incr Step]%1000==0 && [OuiOuNon "On stoppe"]} { break } update idletasks # after 1 # $PAD delete marque if {! $::go} { after 50 update idletasks continue } # select a fourmi set ix [expr {int($TFB(nFourmis)*rand())}] set iF "F[lindex $TFB(LFourmis) $ix]" # puts "\nbouge $iF" # coords de fourmis set xadd [expr {round($TFB(step)*cos($TFB($iF,angle)*[Pi]/180.))}] set yadd [expr {round($TFB(step)*sin($TFB($iF,angle)*[Pi]/180.))}] # puts "xadd $xadd yadd $yadd $TFB($iF,angle)" set bbox [$PAD bbox $iF] lassign $bbox x1 y1 x2 y2 set xn1 [expr {$x1 + $xadd}] set yn1 [expr {$y1 + $yadd}] set xn2 [expr {$x2 + $xadd}] set yn2 [expr {$y2 + $yadd}] set nbb [list $xn1 $yn1 $xn2 $yn2] set deplace 0 set xd 0 ; set yd 0 if {[SortiePlateau $iF $nbb]} { TourneFourmi $iF OnSortPas $iF set nbb [$PAD bbox $iF] } else { $PAD move $iF $xadd $yadd } # test choc switch [MeetBall $iF $bbox $nbb] { "repart" { set TFB($iF,oldAng) $TFB($iF,angle) set TFB($iF,angle) [BonAngle [expr {359.*rand()}]] TourneFourmi $iF OnSortPas $iF } "danslemur" { # on a la bbox avant deplacement # on cherche de quel cote on tape set TFB($iF,oldAng) $TFB($iF,angle) if {$x1 < $x1m} { # tape mur a gauche set ang [BonAngle [expr {180.*rand() + 90.}]] } elseif {$x2 > $x2m} { # tape mur a droite set ang [BonAngle [expr {-180.*rand() + 90.}]] } elseif {$y1 < $y1m} { # tape mur par le haut set ang [BonAngle [expr {-180.*rand()}]] } else { # tape mur par le bas set ang [BonAngle [expr {180.*rand()}]] } set TFB($iF,angle) $ang TourneFourmi $iF set deplace 1 } "droit" { set deplace 1 } } if {$deplace} { #$PAD move $iF $xadd $yadd } lassign [$PAD bbox $iF] a b c d incr a -10 ; incr b -10 incr c 10 ; incr d 10 set Lb [list $a $b $c $d] if {0} { $PAD create rectangle $Lb \ -width 3 \ -outline white \ -tags [list marque] } $PAD raise "fourmi" $PAD raise "ball" # $PAD raise marque } return } proc SortiePlateau {iF nbb} { lassign $nbb x1 y1 x2 y2 set changed 0 set old $::TFB($iF,angle) if {$x1 < 1 || $x2 > ($::TFB(dimX)-1)} { if {$x1 < 1} { set ang [expr {180.*rand() - 90.}] } else { set ang [BonAngle [expr {180.*rand() + 90.}]] } set ::TFB($iF,oldAng) $old set ::TFB($iF,angle) $ang set changed 1 } if {$y1 < 1 || $y2 > ($::TFB(dimY)-1)} { if {$y1 < 1} { set ang [expr { 180.*rand()}] } else { set ang [expr {-180.*rand()}] } set ::TFB($iF,oldAng) $old set ::TFB($iF,angle) $ang set changed 1 } if {$changed} { return 1 } else { return 0 } } proc MeetBallArcEnCiel {iF bbox nbb} { global PAD TFB set HueProche $TFB(HueProche) set itete [$PAD find withtag "$iF && tete"] set Lid [$PAD find overlapping {*}[$PAD bbox $itete]] foreach tid $Lid { set Ltags [$PAD gettags $tid] set HueBoule [lindex $Ltags 1] if {"$iF" in $Ltags} { # la fourmi est contenue dans sa # propre bounding box continue } # si rencontre un mur, repart if {"mur" in $Ltags} { return "danslemur" } # si rencontre le cadre, repart if {"Cadre" in $Ltags} { return "danslemur" } # si rencontre fourmi, repart if {"fourmi" in $Ltags} { return "repart" } # boule prise if {"pris" in $Ltags} { continue } # on rencontre boule if {! $TFB($iF,hasBall)} { if {$TFB($iF,lastBall) != $tid} { # fourmi n a pas de boule # charge boule # puts "charge $tid sur $iF" set TFB($iF,hasBall) $tid set TFB($iF,lastBall) $tid # set TFB($iF,col) [$PAD itemcget $tid -fill] set TFB($iF,hue) $HueBoule BouleSurTete $iF $tid if {[llength $Ltags]<3} { Espionne "Fourmi $iF n'a que les tags $Ltags" exit } lset Ltags 2 "pris" lappend Ltags $iF $PAD itemconfig $tid -tags $Ltags # puts "tags $Ltags" # parray TFB "$iF,*" return "droit" } else { return "droit" } } else { # depose si meme couleur # sinon repart set HueBoule set HueFourmi $TFB($iF,hue) if {$HueBoule<$HueFourmi} { set Mi $HueBoule set Ma $HueFourmi } else { set Mi $HueFourmi set Ma $HueBoule } set DiffHue [expr min($Ma-$Mi, 1.0+$Mi-$Ma)] # set DiffHue [expr min($Ma-$Mi)] if {$DiffHue<$HueProche} { # meme couleur, depose # id de boule a deposer set idd $TFB($iF,hasBall) # puts "depose $idd de $iF" set TFB($iF,hasBall) 0 set Ltags [$PAD gettags $idd] if {[llength $Ltags]<3} { Espionne $Ltags ; exit } lset Ltags 2 "libre" set Ltags [lrange $Ltags 0 end-1] # puts "tags $Ltags" # parray TFB "$iF,*" $PAD itemconfig $idd -tags $Ltags return "repart" } else { return "repart" } } } return "droit" } proc MeetBallTriColor {iF bbox nbb} { global PAD TFB set itete [$PAD find withtag "$iF && tete"] set Lid [$PAD find overlapping {*}[$PAD bbox $itete]] foreach tid $Lid { set Ltags [$PAD gettags $tid] if {"$iF" in $Ltags} { # la fourmi est contenue dans sa # propre bounding box continue } # si rencontre un mur, repart if {"mur" in $Ltags} { return "danslemur" } # si rencontre le cadre, repart if {"Cadre" in $Ltags} { return "danslemur" } # si rencontre fourmi, repart if {"fourmi" in $Ltags} { return "repart" } # boule prise if {"pris" in $Ltags} { continue } # on rencontre boule if {! $TFB($iF,hasBall)} { if {$TFB($iF,lastBall) != $tid} { # fourmi n a pas de boule # charge boule # puts "charge $tid sur $iF" set TFB($iF,hasBall) $tid set TFB($iF,lastBall) $tid set TFB($iF,col) [$PAD itemcget $tid -fill] BouleSurTete $iF $tid if {[llength $Ltags]<3} { Espionne "Fourmi $iF n'a que les tags $Ltags" } lset Ltags 2 "pris" lappend Ltags $iF $PAD itemconfig $tid -tags $Ltags # puts "tags $Ltags" # parray TFB "$iF,*" return "droit" } else { return "droit" } } else { # depose si meme couleur # sinon repart if {$TFB($iF,col) in $Ltags} { # meme couleur, depose # id de boule a deposer set idd $TFB($iF,hasBall) # puts "depose $idd de $iF" set TFB($iF,hasBall) 0 set Ltags [$PAD gettags $idd] if {[llength $Ltags]<3} { Espionne "Fourmi $iF n'a que les tags $Ltags" exit } lset Ltags 2 "libre" set Ltags [lrange $Ltags 0 end-1] # puts "tags $Ltags" # parray TFB "$iF,*" $PAD itemconfig $idd -tags $Ltags return "repart" } else { return "repart" } } } return "droit" } proc TourneListe {xr yr ang Lc} { set cd [expr {cos($ang*[Pi]/180.)}] set sd [expr {sin($ang*[Pi]/180.)}] set Lout [list] foreach {x2 y2} $Lc { set xp [expr {$x2 - $xr}] set yp [expr {$y2 - $yr}] set x [expr {$xp*$cd-$yp*$sd}] set y [expr {$xp*$sd+$yp*$cd}] set xf [expr {round($x + $xr)}] set yf [expr {round($y + $yr)}] lappend Lout $xf $yf } return $Lout } proc TourneFourmi {tag} { global PAD TFB lassign [CentreFourmi $tag] xm ym set ov "" foreach elt [$PAD find withtag $tag] { if {[$PAD type $elt] == "oval"} { set ov $elt continue } set Lc [$PAD coords $elt] set angTot [BonAngle [expr {$TFB($tag,angle) - $TFB($tag,oldAng)}]] set Lc [TourneListe $xm $ym $angTot $Lc] #set Lc [TourneListe $xm $ym [expr {-1.*$TFB($tag,oldAng)}] $Lc] #set Lc [TourneListe $xm $ym $TFB($tag,angle) $Lc] $PAD coords $elt {*}$Lc } if {$ov != ""} { BouleSurTete $tag $ov } set TFB($tag,oldAng) $TFB($tag,angle) return } proc tangle {a b op} { puts "[info level -1]" puts " ang $::TFB(F5,angle)" return } proc OnSortPas {tag} { set dimX $::TFB(dimX) set dimY $::TFB(dimY) set xmin 1 ; set xmax [expr {$dimX - 1}] set ymin 1 ; set ymax [expr {$dimY - 1}] set Lc [$::PAD bbox $tag] foreach {x y} $Lc { if {$x < $xmin} {set xmin $x} if {$x > $xmax} {set xmax $x} if {$y < $ymin} {set ymin $y} if {$y > $ymax} {set ymax $y} } set xd 0.0 ; set yd 0.0 if {$xmin < 1} { set xd [expr {-1. * $xmin + 1}] } if {$ymin < 1} { set yd [expr {-1. * $ymin + 1}] } if {$xmax > ($dimX - 1)} { set xd [expr {-1*($xmax - $dimX + 1)}] } if {$ymax > ($dimY - 1)} { set yd [expr {-1*($ymax - $dimY + 1)}] } if {$xd != 0.0 || $yd != 0.0} { # puts "OnSortPas $xd $yd" $::PAD move $tag $xd $yd BouleSurTete $tag } return } proc BonAngle {a} { while {$a > 180.} { set a [expr {$a - 360.}] } while {$a < -180.} { set a [expr {$a + 360.}] } return $a } proc CentreFourmi {id} { set xm 0 ; set ym 0 set n 0 foreach e [$::PAD find withtag $id] { if {[$::PAD type $e] == "oval"} { foreach {x y} [$::PAD coords $e] { set xm [expr {$xm + $x}] set ym [expr {$ym + $y}] incr n } } else { foreach {x y} [$::PAD coords $e] { set xm [expr {$xm + $x}] set ym [expr {$ym + $y}] incr n } } } set xm [expr {round($xm/$n)}] set ym [expr {round($ym/$n)}] #rR pourquoi des entiers pour le centre ? return [list $xm $ym] } proc BouleSurTete {iF {tid ""}} { if {$tid eq ""} { set tid [$::PAD find withtag "$iF && ball"] if {$tid == {} } { return } } set id [$::PAD find withtag "$iF && tete"] set xc 0.0 ; set yc 0.0 set n 0 foreach {x y} [$::PAD coords $id] { set xc [expr {$xc + $x}] set yc [expr {$yc + $y}] incr n } # puts "boule $tid sur $iF , corps $id" set xc [expr {round($xc/$n)}] set yc [expr {round($yc/$n)}] # puts "-> $xc $yc" lassign [$::PAD coords $tid] x1 y1 x2 y2 set xb [expr {($x1 + $x2) / 2}] set yb [expr {($y1 + $y2) / 2}] set vx [expr {$xc - $xb}] set vy [expr {$yc - $yb}] # puts "-> $vx $vy" #$::PAD moveto $tid $xc $yc $::PAD move $tid $vx $vy $::PAD raise $tid return }