DouKaku?beta

challenge マルバツゲーム：賢いプレイヤー

#6190 の続編です。
マルバツゲームで、賢いプレイヤーの思考ルーチンを実装してください。

賢いといってもいろいろありますが、
１．負けない
２．できるだけ勝つ
という条件でいってみたいと思います。

ランダムプレイヤーと１万回バトルした結果（勝ち・負け・分け）を表示してください。
先攻になっても後攻になっても無敗！となれば言うことなしです。
post comment

Posted feedbacks - Scheme

shuffle便利ですね。lset-ほにゃららをうまく使った方がきれいに書けますね。ということで、gemmaさんにインスパイアされた書き方で挑戦。 アルゴリズムは以下のURIから。 http://2.csx.jp/~3ji-shiki/karegame/tic-tac-toe.html ; random vs random player1 won: 5838 player2 won: 2892 draw: 1270 ; wise vs random player1 won: 9466 player2 won: 0 draw: 534 ; random vs wise player1 won: 0 player2 won: 8362 draw: 1638 ; wise vs wise player1 won: 0 player2 won: 0 draw: 10000 
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
(use srfi-1)
(use gauche.sequence)

(define lset-board  '(0 1 2 3 4 5 6 7 8))
(define lset-corner '(0 2 6 8))
(define lset-edge   '(1 3 5 7))

(define (win? l)
  (any (cut lset<= = <> l)
       '((0 1 2) (3 4 5) (6 7 8) (0 3 6) (1 4 7) (2 5 8) (0 4 8) (2 4 6))))

(define (vacant self other)
  (lset-difference = lset-board (append self other)))

(define (player-random self other)
  (cond ((vacant self other) pair?
     => (lambda (v)
          (cons (car (shuffle v)) self)))
    (else #f)))

(define (player-wise self other)
  (define (next-win v pself)
    (cond ((find win? (map (cut cons <> pself) v))
       => car)
      (else #f)))

  (define (corner-has-neighber corners)
    (define table '((0 1 3) (2 1 5) (6 3 7) (8 7 5)))
    (find (lambda (c)
        (and (pair? (lset-intersection = (cdr (assq c table)) other)) c))
      corners))
    
  (cond ((vacant self other) 
     pair? => (lambda (v)
            (cond ((next-win v self)  => (cut cons <> self))
              ((next-win v other) => (cut cons <> self))
              ((memq 4 v)            (cons 4 self))
              ((or (lset= = other '(0 8)) ;; oxo
                   (lset= = other '(2 6)))
               (cons (car (lset-intersection = v lset-edge))
                 self))
              ((lset-intersection = v lset-corner)
               pair? => (lambda (cs)
                      (cons
                       (or (corner-has-neighber cs)
                       (car cs))
                       self)))
              (else ; edge
               (cons (car v) self))
              )))
    (else #f)))

(define (a-play p1a p2a)
  (define (p1-turn p1 p2)
    (cond ((win? p2) 'lose)
      ((p1a p1 p2) => (cut p2-turn <> p2))
      (else 'draw)))
  (define (p2-turn p1 p2)
    (cond ((win? p1) 'win)
      ((p2a p2 p1) => (cut p1-turn p1 <>))
      (else 'draw)))
  (p1-turn () ()))

(define (play p1a p2a)
  (let new-game ((win 0)
         (lose 0)
         (draw 0))
    (if (<= 10000 (+ win lose draw))
    (format #t "player1 won: ~a\tplayer2 won: ~a\tdraw: ~a\n" win lose draw)
    (case (a-play p1a p2a)
      ((win)  (new-game (+ win 1) lose draw))
      ((lose) (new-game win (+ lose 1) draw))
      ((draw) (new-game win lose (+ 1 draw)))))))

(play player-random player-random)
(play player-wise player-random)
(play player-random player-wise)
(play player-wise player-wise)

お昼休みに少しチューニングしてみました。lset系をやめて、タイトループ中の探索はanyとかfindとか使わずに手で書いて、枝狩りをしたら10倍ぐらい速くなりました。

意外な発見。pa$はcutやlambda書くより遅いですね。

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
(use srfi-1)
(use srfi-27)
(use util.list)

(define lset-board  '(0 1 2 3 4 5 6 7 8))
(define lset-corner '(0 2 6 8))
(define lset-edge   '(1 3 5 7))

(define (includes? a b)
  (cond
   ((null? b) ())
   ((memq (car b) a)
    (includes? a (cdr b)))
   (else #f)))

(define (sand a b)
  (filter (cut memq <> b) a))

(define (sdif a b)
  (remove (cut memq <> b) a))

(define (win? l)
  (let next ((pat '((0 1 2) (3 4 5) (6 7 8) 
            (0 3 6) (1 4 7) (2 5 8) 
            (0 4 8) (2 4 6))))
    (cond
     ((null? pat) #f)
     ((includes? l (car pat)) #t)
     (else (next (cdr pat))))))

(define (vacant self other)
  (sdif lset-board (append self other)))

(define (player-random self other)
  (define (random-take klist)
    (ref klist (random-integer (length klist))))

  (cond
   ((vacant self other)
    pair? => (lambda (v) (cons (random-take v) self)))
   (else #f)))

(define (player-wise self other)
  (define (next-win vs self)
    (cond
     ((< (length self) 2) #f) ;; shortcut
     ((find win? (map (cut cons <> self) vs))
      => car)
     (else #f)))

  (define (corner-has-neighber vcorners)
    (define table '((0 1 3) (2 1 5) (6 3 7) (8 7 5)))
    (define (has-neighber? vc)
      (and (includes? vc '(1 3 5 7)) ;; shortcut
       (pair? (sand (cdr (assq vc table)) other))))
    (find (lambda (vc) (and (has-neighber? vc) vc))
      vcorners))
    
  (cond
   ((vacant self other)
    pair? => (lambda (v)
           (cond
        ((next-win v self)  => (cut cons <> self))
        ((next-win v other) => (cut cons <> self))
        ((memq 4 v)            (cons 4 self))
        ((and (= 2 (length other))
              (or (includes? other '(0 8))
              (includes? other '(2 6))))
         (cons (car (lset-intersection = v lset-edge))
               self))
        ((sand v lset-corner)
         pair? => (lambda (cs)
                (cons
                 (or (corner-has-neighber cs)
                 (car cs))
                 self)))
        (else ; edge
         (cons (car v) self))
        )))
   (else #f)))

(define (a-play p1a p2a)
  (define (p1-turn p1 p2)
    (cond
     ((win? p2) 'lose)
     ((p1a p1 p2) => (cut p2-turn <> p2))
     (else 'draw)))
  (define (p2-turn p1 p2)
    (cond
     ((win? p1) 'win)
     ((p2a p2 p1) => (cut p1-turn p1 <>))
     (else 'draw)))
  (p1-turn () ()))

(define (play p1a p2a)
  (let new-game ((win 0)
         (lose 0)
         (draw 0))
    (if (<= 10000 (+ win lose draw))
    (format #t "player1 won: ~a\tplayer2 won: ~a\tdraw: ~a\n" win lose draw)
    (case (a-play p1a p2a)
      ((win)  (new-game (+ win 1) lose draw))
      ((lose) (new-game win (+ lose 1) draw))
      ((draw) (new-game win lose (+ 1 draw)))))))

(time (play player-random player-random))
(time (play player-wise player-random))
(time (play player-random player-wise))
(time (play player-wise player-wise))

Index

Feed

Other

Link

Pathtraq

loading...
Creative Commons License このサイトの内容は、 クリエイティブ・コモンズ・ライセンスの下でライセンスされています。 [詳細]