;;; Fichier solitaire01.drs / 25 mars 2001

(define (solitaire) (boucle (faire-table)))

(define (boucle tab) 
  (affiche-table tab)
  (let ((coup (choisir-coup)))
    (cond ((member (cadr coup) '(k p c t))
           (boucle (trans-couleur (car coup) (cadr coup) tab)))
          ((eq? (cadr coup) 'r) (boucle (trans-reserve tab)))
          (else (boucle (trans-colonne (car coup) (cadr coup) tab))))))

(define (affiche-table tab)
  (display "Réserve: ") (display (car (cdr (assoc 'r tab)))) (newline)
  (display "Colonne 1: ") (cacher (caddr (assoc 'c1 tab))) (affiche (reverse (cadr (assoc 'c1 tab)))) (newline)
  (display "Colonne 2: ") (cacher (caddr (assoc 'c2 tab))) (affiche (reverse (cadr (assoc 'c2 tab)))) (newline)
  (display "Colonne 3: ") (cacher (caddr (assoc 'c3 tab))) (affiche (reverse (cadr (assoc 'c3 tab)))) (newline)
  (display "Colonne 4: ") (cacher (caddr (assoc 'c4 tab))) (affiche (reverse (cadr (assoc 'c4 tab)))) (newline)
  (display "Colonne 5: ") (cacher (caddr (assoc 'c5 tab))) (affiche (reverse (cadr (assoc 'c5 tab)))) (newline)
  (display "Colonne 6: ") (cacher (caddr (assoc 'c6 tab))) (affiche (reverse (cadr (assoc 'c6 tab)))) (newline)
  (display "Colonne 7: ") (cacher (caddr (assoc 'c7 tab))) (affiche (reverse (cadr (assoc 'c7 tab)))) (newline)
  (display "Pique: ") (affiche (cadr (assoc 'p tab))) (newline)
  (display "Coeur: ") (affiche (cadr (assoc 'c tab))) (newline)
  (display "Trefle: ") (affiche (cadr (assoc 't tab))) (newline)
  (display "Carreau: ") (affiche (cadr (assoc 'k tab))) (newline))

(define (cacher x) (map (lambda (a) (display "* ")) x))
(define (affiche x)
  (cond ((null? x) 'rien)
        ((pair? x) (map (lambda (a) (display a) (display " ")) x))
        (else (display x) (display " "))))

(define (choisir-coup)
  (display "- Choix: ")
  (let ((x (read))) (display "- Vers: ") (list x (read))))

(define (faire-table)
  (let* ((j1 (melange (jeu-de-cartes) 50))
         (j2 (nthcdr j1 1))
         (j3 (nthcdr j2 2))
         (j4 (nthcdr j3 3))
         (j5 (nthcdr j4 4))
         (j6 (nthcdr j5 5))
         (j7 (nthcdr j6 6))
         (r (nthcdr j7 7)))
    (list (cons 'r j7)
          (list 'c1 (list (car j1)) ())
          (list 'c2 (list (car j2)) (list (cadr j2)))
          (list 'c3 (list (car j3)) (cdr (nthcar j3 2)))
          (list 'c4 (list (car j4)) (cdr (nthcar j4 3)))
          (list 'c5 (list (car j5)) (cdr (nthcar j5 4)))
          (list 'c6 (list (car j6)) (cdr (nthcar j6 5)))
          (list 'c7 (list (car j7)) (cdr (nthcar j7 6)))
          (list 'p ())
          (list 'c ())
          (list 'k ())
          (list 't ()))))

(define (met x x-val tab)
  (cond ((null? tab) ())
        ((eq? x (caar tab)) (cons x-val (cdr tab)))
        (else (cons (car tab) (met x x-val (cdr tab))))))

(define (trans-couleur x y tab)
  (let* ((col-x (assoc x tab))
         (x-visible (cadr col-x))
         (x-cache (caddr col-x))
         (new-x-visible (if (null? (cdr x-visible)) (list (car x-cache)) x-visible))
         (new-x-cache (if (null? (cdr x-visible)) (cdr x-cache) x-cache))
         (new-col-x (list x new-x-visible new-x-cache))
         (new-coul-y (list y (append '(toto)))))
    (met x new-col-x (met y new-coul-y tab))))
                   
(define (trans-colonne x y tab)
  (let* ((col-x (assoc x tab))
         (col-y (assoc y tab))
         (x-visible (cadr col-x))
         (y-visible (cadr col-y))
         (test-x-y (colle x-visible y-visible ())))
    (if (null? test-x-y) tab
        (let* ((x-cache (caddr col-x))
               (new-x-visible (cond ((and (null? (car test-x-y)) (null? x-cache)) ())
                                    ((null? (car test-x-y)) (list (car x-cache)))
                                    (else (car test-x-y))))
               (new-x-cache (cond ((null? x-cache) ())
                                  ((null? (car test-x-y)) (cdr x-cache))
                                  (else x-cache)))
               (new-y-visible (cadr test-x-y))
               (new-col-x (list x new-x-visible new-x-cache))
               (new-col-y (list y new-y-visible (caddr col-y))))
          (met x new-col-x (met y new-col-y tab))))))

(define (colle x-visible y-visible sup-y-visible)
  (cond ((null? x-visible) (display "Impossible!!!") (newline) ())
        ((suite? (car x-visible) (car y-visible))
         (list (cdr x-visible) (append (reverse (cons (car x-visible) sup-y-visible)) y-visible)))
        (else (colle (cdr x-visible) y-visible (cons (car x-visible) sup-y-visible)))))

(define (suite? carte1 carte2)
  (and (= (valeur carte1) (- (valeur carte2) 1))
       (not (eq? (couleur carte1) (couleur carte2)))))
  







(define (melange l n)
  (if (or (null? l) (= n 0)) l
      (melange (insert (car l) (cdr l)) (- n 1))))
 
(define (insert el l)
  (let ((n (random (length l))))
    (append (nthcar l (- n 1)) (list el) (nthcdr l n))))

(define val '(1 2 3 4 5 6 7 8 9 10 v d r))

(define (valeur carte) (length (member (car carte) (reverse val))))
(define (couleur carte) (case (cadr carte) ((pique trefle) 'noir) ((carreau coeur) 'rouge)))

(define (jeu-de-cartes)
  (append (associe 'carreau) (associe 'pique) (associe 'trefle) (associe 'coeur)))

(define (associe couleur)
  (map (lambda (x) (list x couleur)) val))

(define (distribue l)
  (let ((n (/ (length l) 2))) (list (nthcar l (- n 1)) (nthcdr l n))))

(define (nthcar l n) (if (< n 0) () (cons (car l) (nthcar (cdr l) (- n 1)))))

(define (nthcdr l n) (if (or (= n 0) (null? l)) l (nthcdr (cdr l) (- n 1))))

          
(solitaire)