fork download
copy 
  1. #lang racket
  2.  
  3. (require (only-in srfi/1
  4.                  circular-list
  5.                  lset-difference))
  6.  
  7. ;;; トランプの構造体
  8.  
  9. (struct Card (suit number) #:transparent)
  10.  
  11. ;;; カードを引く
  12.  
  13. (define (drawCard player1 player2 pos)
  14.   (let-values (((head tail) (split-at player2 pos)))
  15.     (let ((card (car tail)))
  16.       (values card (cons card player1) (append head (cdr tail))))))
  17.  
  18. ;;; カードを捨てる
  19.  
  20. (define (discardPair player)
  21.   (let ((p (map car
  22.                (filter (lambda (x)
  23.                          (odd? (length x)))
  24.                       (group-by Card-number player)))))
  25.     (values (lset-difference equal? player p) p)))
  26.  
  27. ;;; num枚のカードから引くカードを決める
  28. (define selectCard random)
  29.  
  30. ;;; カードを配る
  31.  
  32. (define (dealCards deck n)
  33.   (let ((i (quotient (length deck) n)))
  34.     (let loop ((deck deck) (acc '()))
  35.       (cond ((null? deck) acc)
  36.            ((< (length deck) i)
  37.             (let ((j (length deck)))
  38.               (loop '() (append (map cons deck (take acc j))
  39.                                (drop acc j)))))
  40.            (else
  41.             (loop (drop deck i) (cons (take deck i) acc)))))))
  42.  
  43. ;;; カードをシャッフルする
  44.  
  45. (define (shuffle-list lst n)
  46.   (foldl (lambda (x y)
  47.            (shuffle y)) lst (range n)))
  48.  
  49. ;;; メッセージ
  50.  
  51. (define *messages*
  52.   '((inputSelectCard . "何枚目のカードを引きますか? (0 〜 ~a)\n")
  53.     (showNumCard . "プレイヤー~aのカード: ~a枚\n")
  54.     (showCards . "プレイヤー~aのカード: ~a\n")
  55.     (showDiscardCards . "プレイヤー~aが捨てたカード: ~a\n")
  56.     (showDrawCard . "プレイヤー~a -> プレイヤー~a : ~a\n")
  57.     (showResult . "プレイヤー~aの負けです...")
  58.     (getCardStr . "[~a:~a]")))
  59.  
  60. ;;; 手持ちのカードを表示する文字列
  61.  
  62. (define (showCards players)
  63.   (apply string-append
  64.         (map (lambda (x y)
  65.                (if (zero? x)
  66.                   (format
  67.                    (cdr (assq 'showCards *messages*))
  68.                    x (getCardsStr y))
  69.                   (format
  70.                    (cdr (assq 'showNumCard *messages*))
  71.                    x (length y))))
  72.             (range (length players)) players)))
  73.  
  74. ;;; 捨てられたカードを表示する文字列
  75.  
  76. (define (showDiscardCards id cards)
  77.   (if (null? cards)
  78.      ""
  79.      (format (cdr (assq 'showDiscardCards *messages*))
  80.             id (getCardsStr cards))))
  81.  
  82. ;;; カードの交換状況を表示する文字列
  83.  
  84. (define (showDrawCard id1 id2 card)
  85.   (format (cdr (assq 'showDrawCard *messages*))
  86.          id1 id2 (getCardStr card)))
  87.  
  88. ;;; ゲームの結果を表示する文字列
  89.  
  90. (define (showResult id)
  91.   (format (cdr (assq 'showResult *messages*)) id))
  92.  
  93. ;;; Cardオブジェクトのリストを文字列に変換
  94.  
  95. (define (getCardsStr cards)
  96.   (apply string-append
  97.         (map getCardStr cards)))
  98.  
  99. ;;; Cardオブジェクトを文字列に変換
  100.  
  101. (define (getCardStr card)
  102.   (format (cdr (assq 'getCardStr *messages*))
  103.          (Card-suit card) (Card-number card)))
  104.  
  105. ;;; トランプのカードを作成する
  106.  
  107. (define (make-deck)
  108.   (cons (Card "J" "0")
  109.        (append-map (lambda (suit)
  110.                      (map (lambda (number)
  111.                             (Card (cond ((zero? suit) "D")
  112.                                        ((= suit 1) "H")
  113.                                        ((= suit 2) "S")
  114.                                        (else "C"))
  115.                                  (cond ((zero? number) "A")
  116.                                       ((= number 10) "J")
  117.                                       ((= number 11) "Q")
  118.                                       ((= number 12) "K")
  119.                                       (else (number->string
  120.                                              (+ 1 number))))))
  121.                          (range 13))) (range 4))))
  122.  
  123. ;;; 環境
  124.  
  125. (struct world (card clist discarded dpair id1 id2 players)
  126.   #:transparent)
  127.  
  128. ;;; read
  129.  
  130. (define (input w)
  131.   (let ((id1 (world-id1 w))
  132.         (id2 (world-id2 w))
  133.         (players (world-players w)))
  134.     (let ((k (length (list-ref players id2))))
  135.       (cond ((zero? id1)
  136.              (display
  137.               (format (cdr (assq 'inputSelectCard *messages*))
  138.                      (- k 1)))
  139.              (read))
  140.            (else (selectCard k))))))
  141.  
  142. ;;; eval
  143.  
  144. (define (world-go exp w)
  145.   ;;; world 構造体を組み立て直す材料は4つしか必要ない
  146.   (let ((clist (world-clist w))
  147.         (id1 (world-id1 w))
  148.         (id2 (world-id2 w))
  149.         (players (world-players w)))
  150.     ;;; カードを引く側、引かれる側、を定義する
  151.     (let ((player1 (list-ref players id1))
  152.           (player2 (list-ref players id2)))
  153.       ;;; player1 が player2 からカードを引く
  154.       (let-values (((card player1 player2)
  155.                     (drawCard player1 player2 exp)))
  156.         ;;; player1 がペアになったカードを捨てる
  157.         (let-values (((discarded player1)
  158.                       (discardPair player1)))
  159.           ;;; players リストを更新する
  160.           (let ((players (insert id1 player1
  161.                                 (insert id2 player2 players))))
  162.             ;;; id1 を更新する
  163.             (let ((new-id1 (next-id clist (add1 id1) players)))
  164.               ;;; 新しい id1 を利用して id2 を計算する
  165.               (let ((new-id2 (next-id clist (add1 new-id1) players)))
  166.                 ;;; 新しい world 構造体を生成し返り値とする
  167.                 (world card clist discarded
  168.                       ;;; 出力用に更新前の id1 と id2 を保持する
  169.                       (cons id1 id2)
  170.                       new-id1 ;; 更新後の id1
  171.                       new-id2 ;; 更新後の id2
  172.                       ;;; 新しい players
  173.                       players)))))))))
  174.  
  175. ;;;; let* と let*-values を用いた eval 
  176. ;
  177. ;(define (world-go exp w)
  178. ;  (let* ((clist (world-clist w))
  179. ;         (id1 (world-id1 w))
  180. ;         (id2 (world-id2 w))
  181. ;         (players (world-players w))
  182. ;         (player1 (list-ref players id1))
  183. ;         (player2 (list-ref players id2)))
  184. ;    (let*-values (((card player1 player2)
  185. ;                   (drawCard player1 player2 exp))
  186. ;                  ((discarded player1) (discardPair player1)))
  187. ;      (let* ((players (insert id1 player1
  188. ;                             (insert id2 player2 players)))
  189. ;             (new-id1 (next-id clist (add1 id1) players))
  190. ;             (new-id2 (next-id clist (add1 new-id1) players)))
  191. ;        (world card clist discarded
  192. ;              (cons id1 id2) new-id1 new-id2 players)))))
  193.  
  194. ;;; print
  195.  
  196. (define (print w)
  197.   (let ((card (world-card w))
  198.         (discarded (world-discarded w))
  199.         (dpair (world-dpair w))
  200.         (players (world-players w)))
  201.     (let ((head (car dpair)) (tail (cdr dpair)))
  202.       (display
  203.        (string-append
  204.         (showDrawCard tail head card)
  205.         (showDiscardCards head discarded)
  206.         (showCards players)))))
  207.   w)
  208.  
  209. ;;; ゲーム終了判定
  210.  
  211. (define (game-ends? w)
  212.   (let ((id1 (world-id1 w)) (id2 (world-id2 w)))
  213.     (= id1 id2)))
  214.  
  215. ;;; 補助関数
  216.  
  217. (define (next-id clist id players)
  218.   (let ((pos (list-ref clist id)))
  219.     (let ((player (list-ref players pos)))
  220.       (if (null? player)
  221.          (next-id clist (add1 pos) players)
  222.          pos))))
  223.  
  224. (define (insert id player players)
  225.   (let-values (((head tail) (split-at players id)))
  226.     (append head (cons player (cdr tail)))))
  227.  
  228. (define (make-clist n)
  229.   (apply circular-list (range n)))
  230.  
  231. ;;; 初期化
  232.  
  233. (define (initialize n)
  234.   ;;; プレイヤー達(カードのリストのリスト)を生成
  235.   (let ((players (dealCards (shuffle-list (make-deck) 7) n)))
  236.     ;;; プレイヤー達のカードを表示する
  237.     (display (showCards players))
  238.     ;;; 各プレイヤーにペアを捨てさせ、捨てたカードを表示する
  239.     (let ((players (map (lambda (x y)
  240.                           (let-values (((discarded player)
  241.                                         (discardPair y)))
  242.                             (display
  243.                              (showDiscardCards x discarded))
  244.                             player))
  245.                        (range (length players)) players)))
  246.       ;;; 現時点でのプレイヤー達のカードを表示する
  247.       (display (showCards players))
  248.       ;;; world構造体の初期値を返す
  249.       (world #f (make-clist n) '() '() 0 1 players))))
  250.  
  251. ;;; REPL
  252.  
  253. (define (oldmaid n)
  254.   (let loop ((w (initialize n)))
  255.     ;;; ここで例外処理を記述する
  256.     (with-handlers ((exn:fail:contract?
  257.                      ;;; 例外処理
  258.                      (lambda (ext) (display "入力が不正です\n")
  259.                        (loop w))))
  260.       ;;; 本体
  261.       (if (game-ends? w)
  262.          (display (showResult (world-id1 w)))
  263.          ;;; Read-Eval-Print loop
  264.          (loop (print (world-go (input w) w)))))))
  265.  
  266. ;;;; 四人プレイの場合
  267. ;(oldmaid 4)
Success #stdin #stdout 0.72s 115608KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
Standard output is empty
https://ideone.com/zfbKPh
language:
Racket (racket 7.0)
created:
2 years ago
visibility:
public

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!