;Programme de SAGIT Olivier
;sagit@mail.cpod.fr
;http://www.cpod.com/monoweb/netflyer/

;Le jeu se prensente sous la forme d'une aire de jeu creuse de 2 rangees de six trous.
;Chaque trou contient initialement 4 billes.
;Le but du jeu est de recolter le plus de billes, pour cela
;on prend les billes contenues dans un trou (toujours de son cote), et on les distribue dans 
;les cases suivante à raison d'une bille par trou. On tourne dans le sens trigonometrique.
;Il y a prise quand un coup se termine dans un trou du camp adverse dont le contenu est porte
;a 2 ou 3 billes, la partie se termine quand un joueur n'a plus de coup a jouer, ou qu'il n'est
;plus possible de faire des prises.
;Les cases sont numerotes de la gauche du joueur vers sa droite, de 0 a 5.


;***fonction distribue (1)***

(define (distrib x liste-case)
  (cond ((= x 0) liste-case)
	(else (cons (+ 1 (car liste-case))
	(distrib (- x 1) (cdr liste-case))))))

(define (distribue x liste-case)
  (let ((y (length liste-case)))
	(if (> x y) (list (- x y) (distrib y liste-case))
	    (list 0 (distrib x liste-case)))))

;***fonction vide-case (2)***

(define (fab-liste l n)
  (let* ((l0 (distribue (list-ref l n) (list-tail l (+ 1 n))))
	(l1  (car l0))
	(l2 (cadr l0)))
    (cond ((= n 0)  (cons 0 l2))
	  (else (cons (car l) (fab-liste (cdr l) (- n 1)))))))
  
(define (vide-case n liste-case)
  (cond ((< n (length liste-case))
	 (cons (car (distribue (list-ref liste-case n) (list-tail liste-case (+ 1 n))))
	       (list (fab-liste liste-case n))))
	(else (cons 0 (list liste-case)))))

;***fonction prise (3)***

(define (prise liste-case)
  (define (aux liste-case  res cpt)
    (cond ((null? liste-case) (cons cpt (list (reverse res))))
	  ((or (= 2 (car liste-case)) (= 3 (car liste-case)))
	   (aux (cdr liste-case) (cons 0 res ) (+ cpt (car liste-case))))
	  (else (list cpt (append (reverse res)  liste-case)))))
  (aux liste-case () 0))

;***fonction distribue-avec-prise (4)***

(define (distribue-avec-prise x liste-case)
 (let ((c (distribue x liste-case))
       (lg (length liste-case)))
   (cond ((< x lg) 
	  (append 
	   (list (car c) (car (prise (list-tail (reverse (cadr c)) (- lg x))))) 
	   (list (append 
		  (reverse (cadr (prise (list-tail (reverse (cadr c)) (- lg x)))))
		  (list-tail (cadr c) x)))))
	 (else (append 
		(list (car c) (car (prise (reverse (cadr c))))) 
		(list (reverse (cadr (prise (reverse (cadr c)))))
			      ))))))

;***fonction joue (5)***

(define (joue n l1 l2 g1)
    (let* ((a (vide-case n l1))
	   (b (distribue-avec-prise (car a) l2))
	   (c (distribue (car b) (cadr a)))
	   (d (distribue-avec-prise (car c) (caddr b))))
      (cond ((< (car a) 7) (list (cadr a) (caddr b) (+ g1 (cadr b))))
	    (else (joue 6 (cadr c) (caddr d) (+ g1 (cadr b) (cadr d)))))))

;***fonction affichage (6)***

(define (affiche j1 j2 l1 l2 g1 g2)
  (cond ((equal? j1 "Nord")
	 (display j1) (display "= ") (display g1)
         (newline) (display l1) (newline) (display l2) (newline)
         (display j2) (display "= ") (display g2) (newline) (newline))
        (else (display j2) (display "= ") (display g2) 
         (newline) (display l2) (newline) (display l1) (newline)
         (display j1) (display "= ") (display g1) (newline) (newline))))

;***fonctions boucle(7)***

(define (erreur)
  (newline)(display "***** mauvaise case *****")(newline))

(define (boucle j1 j2 l1 l2 g1 g2)
  (affiche j1 j2 l1 l2 g1 g2)
  (cond ((equal? '(0 0 0 0 0 0) l1)
	 (newline) (display "***** PARTIE TERMINEE *****") (newline)
	 (if (= g1 g2) (display "Match nul!")
	     (begin (display "Victoire de ")
		    (if (< g1 g2) (display j2) (display j1)))))
        (else (display "Position pour le ")(display j1) (display " ? ")
              (let ((pos (read)))
		(cond ((equal? pos 'q) (display "abandon de ") (display j1))
		      ((not (number? pos)) (erreur) (boucle j1 j2 l1 l2 g1 g2))
                      ((or (< pos 0) (> pos 5)) (erreur) (boucle j1 j2 l1 l2 g1 g2))
                      ((equal? (list-ref (if (equal? j1 "Nord") (reverse l1) l1) pos) 0)
                       (display "***** Case vide *****") (newline)(boucle j1 j2 l1 l2 g1 g2))
                      (else (if (equal? "Nord" j1)
                                (let ((coups (joue pos (reverse l1) l2 g1)))
                                  (boucle j2 j1 (cadr coups) (reverse (car coups)) g2 (caddr coups)))
                                (let ((coups (joue pos l1 (reverse l2) g1)))
                                  (boucle j2 j1 (reverse (cadr coups)) (car coups) g2 (caddr coups))))))))))
 
;***fonction principale (8)***

(define (awele) (boucle "Nord" "Sud" '(4 4 4 4 4 4) '(4 4 4 4 4 4) 0 0))