#lang racket

(require (only-in srfi/1
                 circular-list
                 lset-difference))

;;; トランプの構造体

(struct Card (suit number) #:transparent)

;;; カードを引く

(define (drawCard player1 player2 pos)
  (let-values (((head tail) (split-at player2 pos)))
    (let ((card (car tail)))
      (values card (cons card player1) (append head (cdr tail))))))

;;; カードを捨てる

(define (discardPair player)
  (let ((p (map car
               (filter (lambda (x)
                         (odd? (length x)))
                      (group-by Card-number player)))))
    (values (lset-difference equal? player p) p)))

;;; num枚のカードから引くカードを決める
(define selectCard random)

;;; カードを配る

(define (dealCards deck n)
  (let ((i (quotient (length deck) n)))
    (let loop ((deck deck) (acc '()))
      (cond ((null? deck) acc)
           ((< (length deck) i)
            (let ((j (length deck)))
              (loop '() (append (map cons deck (take acc j))
                               (drop acc j)))))
           (else
            (loop (drop deck i) (cons (take deck i) acc)))))))

;;; カードをシャッフルする

(define (shuffle-list lst n)
  (foldl (lambda (x y)
           (shuffle y)) lst (range n)))

;;; メッセージ

(define *messages*
  '((inputSelectCard . "何枚目のカードを引きますか? (0 〜 ~a)\n")
    (showNumCard . "プレイヤー~aのカード: ~a枚\n")
    (showCards . "プレイヤー~aのカード: ~a\n")
    (showDiscardCards . "プレイヤー~aが捨てたカード: ~a\n")
    (showDrawCard . "プレイヤー~a -> プレイヤー~a : ~a\n")
    (showResult . "プレイヤー~aの負けです...")
    (getCardStr . "[~a:~a]")))

;;; 手持ちのカードを表示する文字列

(define (showCards players)
  (apply string-append
        (map (lambda (x y)
               (if (zero? x)
                  (format
                   (cdr (assq 'showCards *messages*))
                   x (getCardsStr y))
                  (format
                   (cdr (assq 'showNumCard *messages*))
                   x (length y))))
            (range (length players)) players)))

;;; 捨てられたカードを表示する文字列

(define (showDiscardCards id cards)
  (if (null? cards)
     ""
     (format (cdr (assq 'showDiscardCards *messages*))
            id (getCardsStr cards))))

;;; カードの交換状況を表示する文字列

(define (showDrawCard id1 id2 card)
  (format (cdr (assq 'showDrawCard *messages*))
         id1 id2 (getCardStr card)))

;;; ゲームの結果を表示する文字列

(define (showResult id)
  (format (cdr (assq 'showResult *messages*)) id))

;;; Cardオブジェクトのリストを文字列に変換

(define (getCardsStr cards)
  (apply string-append
        (map getCardStr cards)))

;;; Cardオブジェクトを文字列に変換

(define (getCardStr card)
  (format (cdr (assq 'getCardStr *messages*))
         (Card-suit card) (Card-number card)))

;;; トランプのカードを作成する

(define (make-deck)
  (cons (Card "J" "0")
       (append-map (lambda (suit)
                     (map (lambda (number)
                            (Card (cond ((zero? suit) "D")
                                       ((= suit 1) "H")
                                       ((= suit 2) "S")
                                       (else "C"))
                                 (cond ((zero? number) "A")
                                      ((= number 10) "J")
                                      ((= number 11) "Q")
                                      ((= number 12) "K")
                                      (else (number->string
                                             (+ 1 number))))))
                         (range 13))) (range 4))))

;;; 環境

(struct world (card clist discarded dpair id1 id2 players)
  #:transparent)

;;; read

(define (input w)
  (let ((id1 (world-id1 w))
        (id2 (world-id2 w))
        (players (world-players w)))
    (let ((k (length (list-ref players id2))))
      (cond ((zero? id1)
             (display
              (format (cdr (assq 'inputSelectCard *messages*))
                     (- k 1)))
             (read))
           (else (selectCard k))))))

;;; eval

(define (world-go exp w)
  ;;; world 構造体を組み立て直す材料は4つしか必要ない
  (let ((clist (world-clist w))
        (id1 (world-id1 w))
        (id2 (world-id2 w))
        (players (world-players w)))
    ;;; カードを引く側、引かれる側、を定義する
    (let ((player1 (list-ref players id1))
          (player2 (list-ref players id2)))
      ;;; player1 が player2 からカードを引く
      (let-values (((card player1 player2)
                    (drawCard player1 player2 exp)))
        ;;; player1 がペアになったカードを捨てる
        (let-values (((discarded player1)
                      (discardPair player1)))
          ;;; players リストを更新する
          (let ((players (insert id1 player1
                                (insert id2 player2 players))))
            ;;; id1 を更新する
            (let ((new-id1 (next-id clist (add1 id1) players)))
              ;;; 新しい id1 を利用して id2 を計算する
              (let ((new-id2 (next-id clist (add1 new-id1) players)))
                ;;; 新しい world 構造体を生成し返り値とする
                (world card clist discarded
                      ;;; 出力用に更新前の id1 と id2 を保持する
                      (cons id1 id2)
                      new-id1 ;; 更新後の id1
                      new-id2 ;; 更新後の id2
                      ;;; 新しい players
                      players)))))))))

;;;; let* と let*-values を用いた eval 
;
;(define (world-go exp w)
;  (let* ((clist (world-clist w))
;         (id1 (world-id1 w))
;         (id2 (world-id2 w))
;         (players (world-players w))
;         (player1 (list-ref players id1))
;         (player2 (list-ref players id2)))
;    (let*-values (((card player1 player2)
;                   (drawCard player1 player2 exp))
;                  ((discarded player1) (discardPair player1)))
;      (let* ((players (insert id1 player1
;                             (insert id2 player2 players)))
;             (new-id1 (next-id clist (add1 id1) players))
;             (new-id2 (next-id clist (add1 new-id1) players)))
;        (world card clist discarded
;              (cons id1 id2) new-id1 new-id2 players)))))

;;; print

(define (print w)
  (let ((card (world-card w))
        (discarded (world-discarded w))
        (dpair (world-dpair w))
        (players (world-players w)))
    (let ((head (car dpair)) (tail (cdr dpair)))
      (display
       (string-append
        (showDrawCard tail head card)
        (showDiscardCards head discarded)
        (showCards players)))))
  w)

;;; ゲーム終了判定

(define (game-ends? w)
  (let ((id1 (world-id1 w)) (id2 (world-id2 w)))
    (= id1 id2)))

;;; 補助関数

(define (next-id clist id players)
  (let ((pos (list-ref clist id)))
    (let ((player (list-ref players pos)))
      (if (null? player)
         (next-id clist (add1 pos) players)
         pos))))

(define (insert id player players)
  (let-values (((head tail) (split-at players id)))
    (append head (cons player (cdr tail)))))

(define (make-clist n)
  (apply circular-list (range n)))

;;; 初期化

(define (initialize n)
  ;;; プレイヤー達(カードのリストのリスト)を生成
  (let ((players (dealCards (shuffle-list (make-deck) 7) n)))
    ;;; プレイヤー達のカードを表示する
    (display (showCards players))
    ;;; 各プレイヤーにペアを捨てさせ、捨てたカードを表示する
    (let ((players (map (lambda (x y)
                          (let-values (((discarded player)
                                        (discardPair y)))
                            (display
                             (showDiscardCards x discarded))
                            player))
                       (range (length players)) players)))
      ;;; 現時点でのプレイヤー達のカードを表示する
      (display (showCards players))
      ;;; world構造体の初期値を返す
      (world #f (make-clist n) '() '() 0 1 players))))

;;; REPL

(define (oldmaid n)
  (let loop ((w (initialize n)))
    ;;; ここで例外処理を記述する
    (with-handlers ((exn:fail:contract?
                     ;;; 例外処理
                     (lambda (ext) (display "入力が不正です\n")
                       (loop w))))
      ;;; 本体
      (if (game-ends? w)
         (display (showResult (world-id1 w)))
         ;;; Read-Eval-Print loop
         (loop (print (world-go (input w) w)))))))

;;;; 四人プレイの場合
;(oldmaid 4)