;====================================================
; Fichier MORPION.PCS / 26 mars 1998
;====================================================

(define (morpion) (boucle '((- - -) (- - -) (- - -)) 'X 'O))

(define (boucle matrice joueur1 joueur2)
  (writeln "position pour le " joueur1 " ?")
  (let ((ligne (saisie "ligne: ")))
    (if (eqv? ligne 'q) 'abandon
        (let* ((colonne (saisie "colonne: "))
               (new-matrice (nouveau matrice ligne colonne joueur1)))
          (newline)
          (affiche-matrice new-matrice) (newline)
          (cond ((gagne? new-matrice) (display "le gagnant est : ") joueur1)
                ((partie-nulle? new-matrice) (display "partie nulle !!!"))
                (else (boucle new-matrice joueur2 joueur1)))))))

(define (saisie message) (display message) (read))

(define (gagne? m)
  (or (identiques? (car (car m)) (cadr (car m)) (caddr (car m)))
      (identiques? (car (cadr m)) (cadr (cadr m)) (caddr (cadr m)))
      (identiques? (car (caddr m)) (cadr (caddr m)) (caddr (caddr m)))
      (identiques? (car (car m)) (car (cadr m)) (car (caddr m)))
      (identiques? (cadr (car m)) (cadr (cadr m)) (cadr (caddr m)))
      (identiques? (caddr (car m)) (caddr (cadr m)) (caddr (caddr m)))
      (identiques? (car (car m)) (cadr (cadr m)) (caddr (caddr m)))
      (identiques? (car (caddr m)) (cadr (cadr m)) (caddr (car m)))))

(define (identiques? a b c)
  (and (equal? a b) (equal? b c) (not (equal? a '-))))

(define (partie-nulle? m)
  (and (not (member '- (car m)))
       (not (member '- (cadr m)))
       (not (member '- (caddr m)))))

(define (nouveau m i j joueur)
  (new-ligne m i (new-ligne (nieme m i) j joueur)))

(define (new-ligne l i val)
  (cond ((null? l) ())
        ((= i 1) (cons val (cdr l)))
        (else (cons (car l) (new-ligne (cdr l) (- i 1) val)))))
        
(define (nieme l i)
  (if (= i 1) (car l) (nieme (cdr l) (- i 1))))

(define (affiche-matrice m)
  (writeln " " (caar m) " � " (cadar m) " � " (caddar m))
  (writeln "�����������")
  (writeln " " (car (cadr m)) " � " (cadr (cadr m)) " � " (caddr (cadr m)))
  (writeln "�����������")
  (writeln " " (car (caddr m)) " � " (cadr (caddr m)) " � " (caddr (caddr m))))

; liste des codes Ascii DOS pour faire des tableaux:
; �170 �179  �180  �191  �192  �193  �194  �195  �196  �197

;-------------------- VERSION AVEC FENETRE -------------------
(define (clear-graphics) (init-graph) (clear-device) (close-graph))

(define (morpion1) 
  (clear-graphics)
  (boucle1 '((- - -) (- - -) (- - -)) 'X 'O (faire-fenetre)))

(define (boucle1 matrice joueur1 joueur2 w)
  (let* ((point (saisie1 joueur1 w))
         (new-matrice (nouveau matrice (car point) (cdr point) joueur1)))
    (cond ((gagne? new-matrice) (display "le gagnant est : ") joueur1)
          ((partie-nulle? new-matrice) (display "partie nulle !!!"))
          (else (boucle1 new-matrice joueur2 joueur1 w)))))

(define (faire-fenetre)
  (let ((w (make-window "" #t)))
    (window-set-position! w 5 20)     ;...coin superieur, gauche
    (window-set-size! w 5 13)         ;...hauteur, largeur
    (window-clear w)                  ;...trace le cadre
    (window-set-cursor! w 1 3)        ;...curseur en haut, a gauche
    (display ".  .  ." w) (newline w)
    (display "   .  .  ." w) (newline w)
    (display "   .  .  ." w) (newline w)
    (window-set-cursor! w 1 1)
    w))

(define (saisie1 joueur w) (placer '(1 . 1) joueur w))

(define (placer point joueur w)
  (window-set-cursor! w (car point) (* 3 (cdr point)))
  (let* ((n (char->integer (read-char w)))
         (x (car point)) (y (cdr point))
         (new-point (case n
                      (72 (cons (- x 1) y))  ;...fleche haut
                      (77 (cons x (+ y 1)))  ;...fleche droite
                      (80 (cons (+ x 1) y))  ;...fleche bas
                      (75 (cons x (- y 1)))  ;...fleche gauche
                      (else point))))
    (cond ((= n 113) ())     ;...q
          ((= n 13) (display joueur w) new-point)  ;...retour chariot
          ((or (> (car new-point) 3) (< (car new-point) 1)
               (> (cdr new-point) 3) (< (cdr new-point) 1))
           (placer point joueur w))
          (else (placer new-point joueur w)))))