;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Université Pierre et Marie Curie
;;; LI101 - Programmation récursive
;;; Cours 11 et 12, année 2007-2008 
;;;
;;; LE JEU DE MORPION

;;;;;;;;;;;;;;;;;;;;;;
;;; Utilitaires

;;; pourtout? : (alpha -> bool) * LISTE[alpha] -> bool
;;; (pourtout? f xs) renvoie #t si tous les éléments de la liste xs 
;;; vérifient le prédicat f ; renvoie #f sinon
(define (pourtout? f xs)
  (if (pair? xs)
      (and (f (car xs)) (pourtout? f (cdr xs)))
      #t))

;;; existe : (alpha -> bool) * LISTE[alpha] -> alpha+#f
;;; (existe f xs) semi prédicat, renvoie le premier élément de la liste xs 
;;; qui vérifie le prédicat f, s'il existe un tel élément ; renvoie #f sinon
(define (existe f xs)
  (if (pair? xs)
      (or (and (f (car xs)) (car xs)) (existe f (cdr xs)))
      #f))

;;; fst : COUPLE[alpha beta] -> alpha
;;; (fst c) renvoie le premier élément du couple c
(define (fst c)
  (car c))

;;; snd : COUPLE[alpha beta] -> alpha
;;; (fst c) renvoie le second élé©ment du couple c
(define (snd c)
  (cadr c))

;;;;;;;;;;;;;;;;;;;;;;
;;; Types
;;;;;;;;;;;;;;;;;;;;;;
;;; Type CASE = [1..9]
;;; Type MARQUE = { 'X 'O }
;;; Type ALIGNEMENT = LISTE[CASE]
;;; Type ALISTE[alpha beta] = LISTE[COUPLE[alpha beta]]
;;; Type JEU = ALISTE[CASE MARQUE]

;;;;;;;;;;;;;;;;;;;;;;
;;;; JEU

;;; jeu-vide : -> JEU
;;; (jeu-vide) renvoie un jeu vide
(define (jeu-vide)
  (list))

;;; jouer : CASE * MARQUE * JEU -> JEU
;;; (jouer c m j) ajoute au jeu j la marque m sur la case c
(define (jouer c m j)
  (cons (list c m) j))

;;; case-vide? : CASE * JEU -> bool
;;; (case-vide? c j) renvoie #t si la case c du jeu j est vide ;
;;; renvoie #f sinon
(define (case-vide? c j)
  (not (assoc c j)))

;;; alignements : -> LISTE[ALIGNEMENT]
;;; (alignements) renvoie la liste de tous les alignements 
(define (alignements)
  (define (ligne c)
    (list c (+ c 1) (+ c 2)))
  (define (colonne c)
    (list c (+ c 3) (+ c 6)))
  (list (ligne 1) (ligne 4) (ligne 7)
        (colonne 1) (colonne 2) (colonne 3)
        (list 1 5 9) (list 3 5 7)))

;;; valeur-case : CASE * JEU -> MARQUE+#f
;;; (valeur-case c j) renvoie la marque de la case c du jeu j ;
;;; renvoie #f si la case c ne contient pas de marque
(define (valeur-case c j)
  (let ((m (assoc c j)))
    (and m (cadr m))))

;;; valeur-alignement : ALIGNEMENT * JEU -> LISTE[MARQUE+#f]
;;; (valeur-alignement a j) renvoie la liste des marques de l'alignement a,
;;; dans le jeu j. Une case vide est représentée par #f. 
(define (valeur-alignement a j)
  (define (valeur-case-j c)
    (valeur-case c j))
  (map valeur-case-j a))

;;; valeur-jeu : JEU -> LISTE[LISTE[MARQUE+#f]]
;;; (valeur-jeu j) rend la liste de toutes les valeurs des alignements, 
;;; dans le jeu j
(define (valeur-jeu j)
  (define (valeur-alignement-j a)
    (valeur-alignement a j))
  (map valeur-alignement-j (alignements)))

;;; alignement-gagnant? : MARQUE * LISTE[MARQUE] -> bool
;;; (alignement-gagnant? m a) renvoie #t si toutes les marques de 
;;; l'alignement a sont égales à  m ; renvoie #f sinon
(define (alignement-gagnant? m a)
  (define (egal-m m1)
    (equal? m m1))
  (pourtout? egal-m a))

;;; jeu-gagnant : MARQUE * JEU-> LISTE[CASE]+#f
;;; (jeu-gagnant m j) semi-pédicat, renvoie le premier alignement gagnant 
;;; pour la marque m  dans le jeu j  s'il existe un tel alignement ; 
;;; renvoie #f sinon
(define (jeu-gagnant m j)
  (define (alignement-gagnant-m? a)
    (alignement-gagnant? m a))
  (existe alignement-gagnant-m? (valeur-jeu j)))

;;; existe-jeu-gagnant : MARQUE * LISTE[JEU] -> JEU+#f
;;; (existe-jeu-gagnant m j) semi-pédicat, renvoie le premier jeu gagnant 
;;; pour la marque m dans la liste de jeux js s'il existe un tel jeu ; 
;;; renvoie #f sinon
(define (existe-jeu-gagnant m js)
  (define (jeu-gagnant-m? j)
    (jeu-gagnant m j))
  (existe jeu-gagnant-m? js))

;;; coups-possibles : JEU -> LISTE[CASE]
;;; (coups-possibles j) renvoie la liste des cases qui sont vides dans le jeu j
(define (coups-possibles j)
  (define (cette-case-vide? c)
    (case-vide? c j))
  (filtre cette-case-vide? '(1 2 3 4 5 6 7 8 9)))

;;; (jeux-possibles m j) renvoie la liste des jeux qu'il est possible 
;;; d'obtenir en posant la marque m sur une case vide du jeu j
(define (jeux-possibles m j)
  (define (jouer-m-j c)
    (jouer c m j))
  (map jouer-m-j (coups-possibles j)))

;;; autre-marque : MARQUE -> MARQUE
;;; (autre-marque m) renvoie la marque qui n'est pas la marque m
(define (autre-marque m)
  (if (equal? m 'X) 'O 'X))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Arbres de jeux, parties possibles


;;; arbre-jeux : MARQUE * JEU -> ARBRE[JEU]
;;; (arbre-jeux m j) renvoie l'arbre de tous les jeux qu'il est possible 
;;; d'obtenir jusqu'en fin de partie, à partir du jeu j et en posant 
;;; d'abord la marque m
(define (arbre-jeux m j)
  (let* ((js (jeux-possibles m j))
         (jg (existe-jeu-gagnant m js)))
    (if jg
        (ag-noeud j (list (ag-feuille jg)))
        (ag-noeud j (foret-jeux (autre-marque m) js)))))

;;; foret-jeux : MARQUE * LISTE[JEU] -> LISTE[ARBRE[JEU]]
;;; (foret-jeux m js) renvoie la forêt de tous les jeux qu'il est possible 
;;; d'obtenir jusqu'en fin de partie, à partir des jeux de la forêt js, 
;;; en posant d'abord la marque m
(define (foret-jeux m js)
  (if (pair? js)
      (cons (arbre-jeux m (car js)) (foret-jeux m (cdr js)))
      (list)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Profondeur minimale des jeux gagnants

;;; xinf : nat+#f * nat+#f -> bool
;;; (xinf v1 v2) renvoie #t si v1<v2, avec #f représentant l'infini
(define (xinf v1 v2)
  (and v1 (or (not v2) (< v1 v2))))
  
;;; xmin : nat+#f * nat+#f -> nat+#f
;;; (xmin v1 v2) donne le minimum de v1 et v2 avec #f à l'infini
(define (xmin v1 v2)
  (if (xinf v1 v2) v1 v2))

;;; x+1 : nat+#f -> nat+#f
;;; (x+1 n) successeur de n avec (x+1 #f) = #f
(define (x+1 n)
  (and n (+ 1 n)))

;;; min-prof-gagnant : MARQUE * ARBRE[JEU] -> nat+#f
;;; (min-prof-gagnant m aj) renvoie la profondeur minimale d'un jeu gagnant 
;;; pour m dans l'arbre des jeux aj
(define (min-prof-gagnant m aj)
  (if (ag-feuille? aj)
      (and (jeu-gagnant m (ag-etiquette aj)) 0) 
      (x+1 (min-prof-gagnant-foret m (ag-foret aj)))))

;;; min-prof-gagnant-foret : MARQUE * LISTE[ARBRE[JEU]] -> nat+#f
;;; (min-prof-gagnant-foret m ajs) renvoie la profondeur minimale d'un jeu
;;; gagnant pour m dans la forêt d'arbre de jeux ajs
(define (min-prof-gagnant-foret m ajs)
  (and (pair? ajs)
       (xmin (min-prof-gagnant m (car ajs))
             (min-prof-gagnant-foret m (cdr ajs)))))

;;; xinf-lex? : COUPLE[nat+#f nat+#f] * COUPLE[nat+#f nat+#f] -> bool
;;; (xinf-lex? c1 c2) renvoie #t si le couple c1 est inférieur au couple c2
;;; dans l'ordre lexicographique, avec #f représentant l'infini
(define (xinf-lex? c1 c2)
  (let ((n1 (fst c1)) (m1 (snd c1))
        (n2 (fst c1)) (m2 (snd c2)))
    (and n1
        (and (not n2) (or (< n1 n2) (and (= n1 n2) (xinf m1 m2)))))))

;;; select-assoc : (alpha * alpha -> bool) * ALISTE[alpha beta] 
;;;                 -> COUPLE[alpha beta]+#f
;;; (select-assoc p abs) renvoie le premier élément (a b) de abs tel que,  
;;; pour tous les éléments (c d) de abs différents de (a b), (p a c) vaut vrai;
;;; renvoie #f si la liste abs est vide
(define (select-assoc p abs)
  (and (pair? abs)
       (let ((ab (select-assoc p (cdr abs))))
         (if ab
             (if (p (fst (car abs)) (fst ab)) (car abs) ab)
             (car abs)))))

;;; valuer-foret-jeu : MARQUE * MARQUE * LISTE[ARBRE[JEU]]
;;;                    -> ALISTE[COUPLE[nat+#f nat+#f] JEU]
;;; (valuer-foret-jeu m-joueur m-opposant ajs) renvoie une liste dans 
;;; laquelle on associe à chaque arbre de jeux aj de ajs le couple formé de 
;;; la profondeur minimale d'un jeu gagnant pour m-joueur dans l'arbre des 
;;; jeux aj et de la profondeur minimale d'un jeu gagnant pour m-opposant 
;;; dans l'arbre des jeux aj
(define (valuer-foret-jeu m-joueur m-opposant ajs)
  (if (pair? ajs)
      (let* ((aj (car ajs))
             (j (ag-etiquette aj)))
        (cons 
         (list (list (min-prof-gagnant m-joueur aj)
                     (min-prof-gagnant m-opposant aj))
               j)
         (valuer-foret-jeu m-joueur m-opposant (cdr ajs))))
      (list)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Jeu interactif, fonction principale

;;; affiche-jeu : JEU -> Rien
;;; (affiche-jeu j) affiche le jeu j
(define (affiche-jeu j)
  (begin
    (display (valeur-alignement '(1 2 3) j))(display"\n")
    (display (valeur-alignement '(4 5 6) j))(display"\n")
    (display (valeur-alignement '(7 8 9) j))(display"\n")))

;;; boucle-jeu : JEU -> Rien
;;; (boucle-jeu j) lance la boucle de jeu à partir du jeu j
(define (boucle-jeu j)
  (begin
    (affiche-jeu j)
    (let* ((c (begin (display "case X ? ") (read)))
           (j (jouer c 'X j)))
      (if (jeu-gagnant 'X j)
          (begin
            (affiche-jeu j)
            (display "Ok, Ok..."))
          (let* ((ajs (foret-jeux 'O (jeux-possibles 'O j)))
                 (cjs (valuer-foret-jeu 'O 'X ajs))
                 (cj (select-assoc xinf-lex? cjs)))
            (if cj
                (let ((j (jouer (fst (car (snd cj))) 'O j)))
                  (if (jeu-gagnant 'O j)
                      (begin
                        (affiche-jeu j)
                        (display "Ouaaaaaaaais !!!"))
                      (boucle-jeu j)))
                (display "j'arrete la")))))))

;;;;;;;;;;;;;;;;;;;;
;;; Lancement du jeu

(boucle-jeu (jeu-vide))