<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
<html>
  <head>

    <meta http-equiv="content-type" content="text/html; charset=ISO-8859-1">
  </head>
  <body bgcolor="#ffffff" text="#000000">
    <div id="gt-src-tools">
      <div id="gt-src-tools-l">
        <div style="display: inline-block;" id="gt-input-tool">
          <div id="itamenu"><span class="ita-kd-inputtools-div"></span></div>
        </div>
      </div>
    </div>
    <div id="gt-res-content" class="almost_half_cell">
      <div dir="ltr" style=""><span id="result_box" class="" lang="en"><span
            class="hps">I wrote a</span> <span class="hps">program
            using</span> <span class="hps">drscheme</span> <span
            class="hps">scheme</span><span>.</span><span class="hps">
            I'm having trouble</span> <span class="hps">getting it to
            work</span> <span class="hps">with</span> <span
            class="hps">racketeering.</span><br>
          <span class="hps">He</span> <span class="hps">tells me</span>
          <span class="hps">the mistakes that</span> <span class="hps">I
            do not</span> <span class="hps">understand.</span><span
            class="hps"> Thank you</span> <span class="hps">for your
            help.</span><br>
            <span class="hps">Here is the source</span> <span
            class="hps">of this program:</span></span></div>
    </div>
    <br>
    <br>
    ;(require (lib "compile.ss"))<br>
    ;(compile-file "gplateau.scm" "../gplateau.zo")<br>
    <br>
    (module gplateau racket<br>
      (provide (all-defined-out))<br>
      <br>
      (require racket/math)<br>
      (require racket/list)<br>
      (require racket/class)<br>
      (require racket/draw)<br>
      (require racket/gui)<br>
      (require framework)<br>
      (require (file "sol-awale.zo"))<br>
      (require (file "meo-plateau.zo"))<br>
      <br>
     <br>
      <br>
      (define bitmapdir (string-append (current-load-relative-directory)
    "Bitmaps/"))<br>
      <br>
      ;; Le numero de joueur courant<br>
      (define JoueurCourant 1)<br>
      ;; Le plateau courant <br>
      (define PlateauCourant (InitialiserPlateau 4 4 4 4 4 4 4 4 4 4 4
    4))<br>
      <br>
      ;; les scores<br>
      (define score1 0)<br>
      (define score2 0)<br>
    <br>
      ;; les dimensions du plateau<br>
      (define plateauX 800)<br>
      (define plateauY 300)<br>
      <br>
      ;; La reinitialisation du plateau<br>
      (define initp<br>
        (lambda ()<br>
          (set! JoueurCourant 1)<br>
          (set! PlateauCourant (InitialiserPlateau 4 4 4 4 4 4 4 4 4 4 4
    4))<br>
          (set! score1 0)<br>
          (set! score2 0)))<br>
      <br>
      <br>
      ;; Le constructeur de case-graphique<br>
      <br>
      ;; ncase: [1;12] x naturel x naturel -> case-graphique<br>
      ;;            n, x, y                -> case-graphique avec le
    numero de case n et la position en x et y du sommet <br>
      ;;                                      (haut a gauche) du carre
    dans lequel est inscrit le cercle de la case<br>
      <br>
      (define ncase (lambda (n x y) (cons (cons n x) y)))<br>
      <br>
      ;; les extracteurs correspondant<br>
      (define num caar)<br>
      (define xpos cdar)<br>
      (define ypos cdr)<br>
      <br>
      ;; Le rayon et le diametre d'une case (graphique)<br>
      (define rayon-case 50)<br>
      (define diametre-case (* 2 rayon-case))<br>
      <br>
      ;; La position des 12 cases graphiques<br>
      <br>
      (define lesCases (list (ncase 1 10 170) (ncase 2 130 170) (ncase 3
    250 170) (ncase 4 370 170) (ncase 5 490 170) (ncase 6 610 170)
    (ncase 7 610 30) (ncase 8 490 30) (ncase 9 370 30) (ncase 10 250 30)
    (ncase 11 130 30) (ncase 12 10 30)))<br>
      <br>
      <br>
      ;; pos-case: [1;12] -> case-graphique<br>
      ;;              c   -> la case graphique correspondant a c<br>
      <br>
      (define pos-case<br>
        (lambda (c) (list-ref lesCases (- c 1))))<br>
      <br>
      <br>
      ;; distance: reel x reel --> reel+<br>
      ;;                  x, y     --> la distance separant le <br>
      ;;                               point de coord. x,y de l'origine.<br>
      (define distance<br>
        (lambda (x y) (sqrt (+ (* x x) (* y y)))))<br>
      <br>
      ;; dans-case: nombre x nombre x nombre x nombre -> booleen<br>
      ;;               x1, y1, x2, y2                 -> le point de
    coordonnees (x2, y2) est dans<br>
      ;;                                                 la case dont le
    cercle est inscrit dans le carre dont le sommet haut <br>
      ;;                                                 gauche est de
    coordonnees (x1, y1)<br>
      <br>
      (define dans-case <br>
        (lambda (x1 y1 x2 y2)<br>
          (let [[dist (distance (- x2 (- x1 rayon-case)) (- y2 (- y1
    rayon-case)))]]<br>
            (< dist rayon-case))))<br>
      <br>
      (define numero-aux <br>
        (lambda (x y l)<br>
          (cond [(null? l) #f]<br>
                [(dans-case x y (xpos (car l)) (ypos (car l))) (num (car
    l))]<br>
                [#t (numero-aux x y (cdr l))])))<br>
      <br>
      <br>
      ;; numero-case: nombre x nombre -> [1;2] U {#f}<br>
      ;;                   x, y       -> donne le numero de la case
    dans laquelle <br>
      ;;                                 figure le point de coordonnees
    (x,y) et faux si le point<br>
      ;;                                 est en dehors des cases<br>
      <br>
      (define numero-case (lambda (x y) (numero-aux x y lesCases)))<br>
      <br>
      <br>
      (define mouse-handler<br>
        (lambda (mo) <br>
          (cond [(not (send mo button-down?)) '()]<br>
                [#t (let [[num-case (numero-case (send mo get-x) (send
    mo get-y))]]<br>
                      (cond <br>
                        [(not num-case) '()]<br>
                        [(not (CaseAppartient? num-case JoueurCourant))
    '()]<br>
                        [(= (NbGrainesCase PlateauCourant num-case) 0)
    '()]<br>
                        [#t<br>
                         (let* [[res (ActionJoueur PlateauCourant
    JoueurCourant num-case)]<br>
                                [nouveau-plateau (car res)]<br>
                                [gain (cdr res)]]<br>
                           (if (= JoueurCourant 1) (set! score1 (+
    score1 gain)) (set! score2 (+ score2 gain)))<br>
                           (set! PlateauCourant nouveau-plateau)<br>
                           (set! JoueurCourant (Adversaire
    JoueurCourant))<br>
                           (AffichePlateau PlateauCourant)<br>
                           (cond ((and (= JoueurCourant 1) (FinJeu?
    PlateauCourant 1))<br>
                                  (set! score2 (+ score2
    (CollecterGraines PlateauCourant 1 6)))<br>
                                  (AffichePlateau PlateauCourant)<br>
                                  (FinJeu))<br>
                                 ((and (= JoueurCourant 2) (FinJeu?
    PlateauCourant 2))<br>
                                  (set! score1 (+ score1
    (CollecterGraines PlateauCourant 7 12)))<br>
                                  (AffichePlateau PlateauCourant)<br>
                                  (FinJeu))))]))])))<br>
      <br>
      <br>
      (define popup (make-object frame% "Fin du Jeu!" #f 200 100))<br>
      (define msg-popup (make-object message%
    "+++++++++++++++++++++++++" popup))<br>
      <br>
      (make-object button% "OK" popup<br>
        (lambda (button event)<br>
          (begin <br>
            (send popup show #f))))<br>
      <br>
      <br>
      ;; La bitmap et le "drawing context" associe, pour le plateau<br>
      <br>
      (define bitmap (make-object bitmap% plateauX plateauY))<br>
      (define dcbit (make-object bitmap-dc%))<br>
      (define frame (make-object frame% "Sol-Awale" #f plateauX (+
    plateauY 30)))<br>
      <br>
      <br>
      (define affiche (lambda(dc) (send dc draw-bitmap bitmap 0 0)))<br>
      <br>
      ;; Le canvas associe au plateau dont les methodes on-paint et
    on-event sont respectivement surchargees  <br>
      ;; par les methodes affiche et le mouse-handler defini au dessus <br>
      <br>
      (define mycanvas% (class canvas% (frame)<br>
                          (inherit get-dc)<br>
                          (override [on-paint (lambda () (affiche
    (get-dc)))]) <br>
                          (override [on-event (lambda (mo)
    (mouse-handler mo))])<br>
                          (sequence (super-init frame ))))<br>
    <br>
      (define canvas (make-object mycanvas% frame))<br>
      (define dc (send canvas get-dc))<br>
      (define pen1 (make-object pen% "BLACK" 1 'transparent))<br>
      (define brush1 (make-object brush% "RED" 'solid))<br>
      <br>
      <br>
      ;; dessine-case: [1;12] x naturel -> vide<br>
      ;;                    c, n        -> dessine la case c avec n
    graines<br>
      <br>
      (define dessine-case<br>
        (lambda (c n)<br>
          (let* [[case (pos-case c)]<br>
                 [xc (xpos case)]<br>
                 [yc (ypos case)]<br>
                 [n2 (if (> n 12) 12 n)]]  ;; au dela de 12 graines
    on ne differencie plus<br>
            (send dcbit draw-bitmap (list-ref lbitmap n2) xc yc))))<br>
      <br>
      <br>
      <br>
      (define black (make-object color% 0 0 0))<br>
      (define white (make-object color% 255 255 255))<br>
      (define red (make-object color% 255 0 0))<br>
      <br>
      (send dcbit set-text-background white)<br>
      (send dcbit set-text-foreground black)<br>
      <br>
      <br>
      ;; AffichePlateau: plateau -> vide<br>
      ;;                      p  -> affiche le plateau p<br>
      <br>
      (define AffichePlateau <br>
        (lambda (p) <br>
          (AfficheAux p 1)<br>
          (if (= JoueurCourant 1)<br>
              (send dcbit set-text-foreground black)<br>
              (send dcbit set-text-foreground red))<br>
          (send dcbit draw-text "Joueur 2" 730 60 #f)<br>
          (send dcbit draw-rectangle 730 80 800 125)<br>
          (send dcbit draw-text (number->string score2) 730 80 #f)<br>
          (if (= JoueurCourant 1)<br>
              (send dcbit set-text-foreground red)<br>
              (send dcbit set-text-foreground black))<br>
          (send dcbit draw-text "Joueur 1" 730 200 #f)<br>
          (send dcbit draw-rectangle 730 220 800 225)<br>
          (send dcbit draw-text (number->string score1) 730 220 #f)<br>
          (affiche dc)<br>
          ))<br>
      <br>
      (define AfficheAux<br>
        (lambda (p c)<br>
          (cond ((= c 12) (dessine-case c (NbGrainesCase p c)) (affiche
    dc))<br>
                (#t (dessine-case c (NbGrainesCase p c)) (AfficheAux p
    (CaseSuivante c))))))<br>
      <br>
      (define FinJeu<br>
        (lambda ()<br>
          (cond ((= score1 score2) (send msg-popup set-label
    "Egalite!"))<br>
                ((> score1 score2) (send msg-popup set-label
    (string-append "Le joueur 1 gagne " (number->string score1) " a "
    (number->string score2))))<br>
                (#t (send msg-popup set-label (string-append "Le joueur
    2 gagne " (number->string score2) " a " (number->string
    score1)))))<br>
          (send popup show #t)))<br>
      <br>
      <br>
      ;; Definition du clipping pour l'affichage des bitmaps
    correspondant aux cases dans <br>
      ;; des cercles propres (les bitmaps sont toujours rectangulaires
    :-/ )<br>
      <br>
      (define clip (make-object region% dcbit))<br>
      <br>
      (for-each <br>
       (lambda (case) <br>
         (let [[clip2 (make-object region% dcbit)]]<br>
           (send clip2 set-ellipse (xpos case) (ypos case) diametre-case
    diametre-case)<br>
           (send clip union clip2)))<br>
       lesCases)<br>
      <br>
      (define clip2 (make-object region% dcbit))<br>
      <br>
      <br>
      ;; On ajoute aussi le rectangle pour l'affichage des scores.<br>
      <br>
      (send clip2 set-rectangle 725 60 800 250)<br>
      (send clip union clip2)<br>
      <br>
      <br>
      <br>
      ;; Chargement de la bitmap de fond du plateau<br>
      (define wood (make-object bitmap% 100 100))<br>
      (send wood load-file (string-append bitmapdir "wood.xpm") 'xpm)<br>
      <br>
      ;; Chargement de la liste de bitmaps pour tous les etats de case
    possible 0, 1, 2...12+ graines<br>
      <br>
      (define lbitmap <br>
        (map (lambda (n) <br>
               (let [[b (make-object bitmap% 100 100)]]<br>
                 (send b load-file (string-append bitmapdir
    (number->string n) ".xpm") 'xpm)<br>
                 b))<br>
             (list 0 1 2 3 4 5 6 7 8 9 10 11 12)))<br>
      <br>
      <br>
      (send brush1 set-stipple wood)<br>
      (send dcbit set-bitmap bitmap)<br>
      (send dcbit clear)<br>
      (send dcbit set-brush brush1)<br>
      (send dcbit set-pen pen1)<br>
      (send dcbit draw-rectangle 0 0 plateauX plateauY)<br>
      <br>
      (send dcbit set-clipping-region clip)<br>
      <br>
      <br>
      <br>
      (AffichePlateau PlateauCourant)<br>
      <br>
      (make-object button% "Recommencer" frame<br>
        (lambda (button event)<br>
          (initp)<br>
          (AffichePlateau PlateauCourant)))<br>
      <br>
      <br>
      (send frame show #t)<br>
      (sleep/yield 1)<br>
      (affiche dc)<br>
      )<br>
  </body>
</html>