オセロ必勝法 Part4

(defun Othello ()
  (setq table nil)
  (setq sq 8)
  (setq r nil)
  (defun initable ()
    (defun initableat ()
      (cond ((not table) (setq table '((0 0))))
            ((= (caar table) (1- sq)) (setq table (push `(0 ,(1+ (cadr (car table)))) table)))
            (t (setq table (push `(,(1+ (caar table)) ,(cadr (car table))) table)))))
    (defun nest (f n)
      (if (zerop n) nil
        (progn (funcall f)
               (nest f (1- n)))))
    (nest 'initableat (* sq sq))
    (setq table (reverse table))
    (setq table (mapcar (lambda (x) (list x 0)) table)))
  (defun setdisk (x y disk)
    (setq table (mapcar (lambda (z) (cond ((and (eq (caar z) x)
                                                (eq (cadr (car z)) y))
                                           (list (list x y) disk))
                                          (t z)))
                        table)))
  (defun subsetdisk (x y disk)
    (setq subtable (mapcar (lambda (z) (cond ((and (eq (caar z) x)
                                                   (eq (cadr (car z)) y))
                                              (list (list x y) disk))
                                             (t z)))
                           subtable)))
  (defun begintable ()
    (setq table nil)
    (initable)
    (setdisk 1 1 t)
    (setdisk 2 1 nil)
    (setdisk 1 2 nil)
    (setdisk 2 2 t)
    (display))
  (defun neighbor (x)
    (cond ((= x 0) '(-1 -1))
          ((= x 1) '(0 -1))
          ((= x 2) '(1 -1))
          ((= x 3) '(-1 0))
          ((= x 4) '(1 0))
          ((= x 5) '(-1 1))
          ((= x 6) '(0 1))
          ((= x 7) '(1 1))))
  (defun getdisk (x y)
    (cadr (elt table (+ (* sq y) x))))
  (defun turnover (x y color)
    (let ((dir nil)
          (flag nil)
          (i 0)
          (subtable table)
          (nei 8))
      ;(if (not (checkturnover x y color)) '(cant put here)
        (progn (setdisk x y color)
               (setq subtable table)
               (defun turnoverat (x y color dir flag)
                 (let ((neix (+ x (car (neighbor dir))))
                       (neiy (+ y (cadr (neighbor dir)))))
                   (if (or (> 0 (+ (* sq neiy) neix))
                           (<= (* sq sq) (+ (* sq neiy) neix))
                           (eq (getdisk neix neiy) 0))
                       (setq subtable table)
                     (if (not flag)
                         (if (eq (getdisk neix neiy) (not color))
                             (progn (subsetdisk neix neiy color)
                                    (turnoverat neix neiy color dir t)))
                       (cond ((eq (getdisk neix neiy) 0) (setq subtable table))
                             ((eq (getdisk neix neiy) (not color))
                              (progn (subsetdisk neix neiy color)
                                     (turnoverat neix neiy color dir t)))
                             ((eq (getdisk neix neiy) color) (setq table subtable)))))))
               (while (< i nei)
                 (turnoverat x y color i flag)
                 (setq i (1+ i))))
        ;)
    )
                                        ;(display)
    table)
  (defun checkturnover (x y color)
    (let ((dir nil)
          (flag nil)
          (i 0)
          (subtable table)
          (nei 8)
          (checkflag nil))
      (if (eq (getdisk x y) 0)
          (progn (defun checkturnoverat (x y color dir flag)
                   (let ((neix (+ x (car (neighbor dir))))
                         (neiy (+ y (cadr (neighbor dir)))))
                     (if (or (> 0 (+ (* sq neiy) neix))
                             (<= (* sq sq) (+ (* sq neiy) neix))
                             (eq (getdisk neix neiy) 0))
                         nil
                       (if (not flag)
                           (if (eq (getdisk neix neiy) (not color))
                               (checkturnoverat neix neiy color dir t))
                         (cond ((eq (getdisk neix neiy) 0))
                               ((eq (getdisk neix neiy) (not color))
                                (checkturnoverat neix neiy color dir t))
                               ((eq (getdisk neix neiy) color) (setq checkflag t)))))))
                 (while (< i nei)
                   (checkturnoverat x y color i flag)
                   (setq i (1+ i)))))
      checkflag))
  (defun displaycolor ()
    (mapcar (lambda (x) (cond ((eq (cadr x) 0) 0)
                              ((eq (cadr x) nil) '●)
                              ((eq (cadr x) t) '○)
                              (t '.)))
            table))
  (defun cutoff (table)
    (let ((i nil)
          (j nil))
      (defun cutoffat (table i j)
        (cond ((eq i nil) (progn (setq i 0)
                                 (setq j 0)
                                 (setq p nil)
                                 (setq q nil)
                                 (cutoffat table i j)))
              ((< i sq) (progn (push (car table) p)
                               (cutoffat (cdr table) (1+ i) j)))
              ((< j sq) (progn (push (reverse p) q)
                               (setq i 0)
                               (setq p nil)
                               (cutoffat table i (1+ j))))
              (t (reverse q))))
      (cutoffat table i j)))
  (defun displaynewline (table)
    (if (eq table nil) nil
      (progn (setq r (concat r (format "%s" (car table)) (string ?\n)))
             (displaynewline (cdr table))))
    r)
  (defun display ()
    (setq r (string ?\n))
    (displaynewline (cutoff (displaycolor))))
  (defun count ()
    (let ((sumb 0)
          (sumw 0))
      (defun countat (table)
        (cond ((eq table nil) nil)
              ((eq (cadr (car table)) nil) (progn (setq sumb (1+ sumb))
                                                  (countat (cdr table))))
              ((eq (cadr (car table)) t) (progn (setq sumw (1+ sumw))
                                                (countat (cdr table))))
              (t (countat (cdr table)))))
      (countat table)
      (cond ((= sumb sumw) 'draw)
            ((> sumb sumw) nil)
            ((< sumb sumw) t))))
  (defun end (table)
    (catch 'loop
      (let ((j 0))
        (while (< j sq)
          (let ((i 0))
            (while (< i sq)
              (if (or (checkturnover i j nil)
                      (checkturnover i j t))
                  (throw 'loop nil))
              (setq i (1+ i))))
          (setq j (1+ j))))
      t))
  (defun strategy (table turn)
    (if (end table) (count)
      (catch 'loop
        (let ((j 0)
              (i 0)   
              (win (not turn))
              (flag nil))
          (while (< j sq)
            (while (< i sq)
              (if (checkturnover i j turn)
                  (let ((x (strategy (turnover i j turn) (not turn))))
                    (cond ((eq turn x)
                           (throw 'loop turn))
                          ((eq 'draw x)
                           (setq win 'draw)))
                    (setq flag t)))
              (setq i (1+ i)))
            (setq i 0)
            (setq j (1+ j)))
          (if (not flag)
              (strategy table (not turn))
            win))))))

というわけで、プログラムは出来たのですが、計算量が多すぎます。
多く見積もっても、10^80分かかります。
どうしたものか・・・

オセロ必勝法 Part3

(defun Othello ()
  (setq table nil)
  (setq sq 8)
  (setq r nil)
  (defun initable ()
    (defun initableat ()
      (cond ((not table) (setq table '((0 0))))
            ((= (caar table) (1- sq)) (setq table (push `(0 ,(1+ (cadr (car table)))) table)))
            (t (setq table (push `(,(1+ (caar table)) ,(cadr (car table))) table)))))
    (defun nest (f n)
      (if (zerop n) nil
        (progn (funcall f)
               (nest f (1- n)))))
    (nest 'initableat (* sq sq))
    (setq table (reverse table))
    (setq table (mapcar (lambda (x) (list x 0)) table)))
  (defun setdisk (x y disk)
    (setq table (mapcar (lambda (z) (cond ((and (eq (caar z) x)
                                                (eq (cadr (car z)) y))
                                           (list (list x y) disk))
                                          (t z)))
                        table)))
  (defun subsetdisk (x y disk)
    (setq subtable (mapcar (lambda (z) (cond ((and (eq (caar z) x)
                                                   (eq (cadr (car z)) y))
                                              (list (list x y) disk))
                                             (t z)))
                           subtable)))
  (defun begintable ()
    (initable)
    (setdisk 3 3 nil)
    (setdisk 3 4 t)
    (setdisk 4 3 t)
    (setdisk 4 4 nil)
    (display))
  (defun neighbor (x)
    (cond ((= x 0) '(-1 -1))
          ((= x 1) '(0 -1))
          ((= x 2) '(1 -1))
          ((= x 3) '(-1 0))
          ((= x 4) '(1 0))
          ((= x 5) '(-1 1))
          ((= x 6) '(0 1))
          ((= x 7) '(1 1))))
  (defun getdisk (x y)
    (cadr (elt table (+ (* sq y) x))))
  (defun turnover (x y color)
    (let ((dir nil)
          (flag nil)
          (i 0)
          (subtable table)
          (nei 8)
          (sq 8))
      (if (not (checkturnover x y color)) '(cant put here)
        (progn (setdisk x y color)
               (defun turnoverat (x y color dir flag)
                 (let ((neix (+ x (car (neighbor dir))))
                       (neiy (+ y (cadr (neighbor dir)))))
                   (if (or (> 0 (+ (* sq neiy) neix))
                           (<= (* sq sq) (+ (* sq neiy) neix))
                           (eq (getdisk neix neiy) 0))
                       (setq subtable table)
                     (if (not flag)
                         (if (eq (getdisk neix neiy) (not color))
                             (progn (subsetdisk neix neiy color)
                                    (turnoverat neix neiy color dir t)))
                       (cond ((eq (getdisk neix neiy) 0) (setq subtable table))
                             ((eq (getdisk neix neiy) (not color))
                              (progn (subsetdisk neix neiy color)
                                     (turnoverat neix neiy color dir t)))
                             ((eq (getdisk neix neiy) color) (setq table subtable)))))))
               (while (< i nei)
                 (turnoverat x y color i flag)
                 (setq i (1+ i)))
               (display)))))
  (defun checkturnover (x y color)
    (let ((dir nil)
          (flag nil)
          (i 0)
          (subtable table)
          (nei 8)
          (sq 8)
          (checkflag nil))
      (defun checkturnoverat (x y color dir flag)
        (let ((neix (+ x (car (neighbor dir))))
              (neiy (+ y (cadr (neighbor dir)))))
          (if (or (> 0 (+ (* sq neiy) neix))
                  (<= (* sq sq) (+ (* sq neiy) neix))
                  (eq (getdisk neix neiy) 0))
              nil
            (if (not flag)
                (if (eq (getdisk neix neiy) (not color))
                    (checkturnoverat neix neiy color dir t))
              (cond ((eq (getdisk neix neiy) 0))
                    ((eq (getdisk neix neiy) (not color)) (checkturnoverat neix neiy color dir t))
                    ((eq (getdisk neix neiy) color) (setq checkflag t)))))))
      (while (< i nei)
        (checkturnoverat x y color i flag)
        (setq i (1+ i)))
      checkflag))
  (defun displaycolor ()
    (mapcar (lambda (x) (cond ((eq (cadr x) 0) 0)
                              ((eq (cadr x) nil) '●)
                              ((eq (cadr x) t) '○)
                              (t '.)))
            table))
  (defun cutoff (table i j)
    (cond ((eq i nil) (progn (setq i 0)
                             (setq j 0)
                             (setq p nil)
                             (setq q nil)
                             (cutoff table i j)))
          ((< i sq) (progn (push (car table) p)
                           (cutoff (cdr table) (1+ i) j)))
          ((< j sq) (progn (push (reverse p) q)
                    (setq i 0)
                    (setq p nil)
                    (cutoff table i (1+ j))))
          (t (reverse q))))
  (defun displaynewline (table)
    (if (eq table nil) nil
      (progn (setq r (concat r (format "%s" (car table)) (string ?\n)))
             (displaynewline (cdr table))))
    r)
  (defun display ()
    (setq r (string ?\n))
    (displaynewline (cutoff (displaycolor) nil nil))))

石をひっくり返す関数と石を置けるかどうかチェックする関数と、
石を表示する関数を作りました。

表示例

(Othello)
display
(begintable)
"
(0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0)
(0 0 0 ● ○ 0 0 0)
(0 0 0 ○ ● 0 0 0)
(0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0)
"
(turnover 3 2 t)
"
(0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0)
(0 0 0 ○ 0 0 0 0)
(0 0 0 ○ ○ 0 0 0)
(0 0 0 ○ ● 0 0 0)
(0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0)
"
(turnover 2 2 nil)
"
(0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0)
(0 0 ● ○ 0 0 0 0)
(0 0 0 ● ○ 0 0 0)
(0 0 0 ○ ● 0 0 0)
(0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0)
"
(turnover 0 0 nil)
(cant put here)

次で終わると思います。
遅れてゴメンネ(><)

ブッダブロのような何か

言語:mathematica

random[] := 4*RandomComplex[] - 2 - 2 I

f[z_, c_] := z^2 + c

onestep[c_, limit_] := 
 NestWhileList[f[#, c] &, 0, Abs[#] < 2 &, 1, limit]

c2pair[z_] := {Re[z], Im[z]}

step[limit_, max_] := onestep[#, limit] & /@ Table[random[], {max}]

makelist[list_] := c2pair /@ Flatten[list]

budda[limit_, max_] := ListPlot[makelist[step[limit, max]]]


f:id:mikuwaorenoyome:20170329104843p:plain

オセロ必勝法 Part2

石を返す前に、石を置くのを忘れてました。
あと、initableをちょっと修正しました。

(defun Osero ()
  (let ((table nil))
  (defun initable (table sq)
    (defun initableat (table)
      (cond ((not table) (setq table '((0 0))))
	    ((= (cadr (car table)) (1- sq)) (setq table (push `(,(1+ (caar table)) 0) table)))
	    (t (setq table (push `(,(caar table) ,(1+ (cadr (car table)))) table)))
	    table))
    (defun nest (f x n)
      (let ((i 0)
	    (out x))
	(while (<= i n)
	  (setq out (funcall f out))
	  (setq i (1+ i)))
	out))
    (defun nulltable (table)
      (mapcar '(lambda (x) (list x 'null)) table))
    (setq table (nulltable (reverse (nest 'initableat nil (1- (* sq sq))))))))
  (defun setdisk (table sq x y disk)
    (setf (cadr (elt table (+ (* sq x) y))) disk)
    table))

(Osero)
setdisk
(initable nil 2)
(((0 0) null) ((0 1) null) ((1 0) null) ((1 1) null))
(setdisk (initable nil 2) 2 1 0 'white)
(((0 0) null) ((0 1) null) ((1 0) white) ((1 1) null))

今度こそ、石を返そうと思います。

オセロ必勝法 Part1

8×8のオセロの必勝法が知りたいので、それを目標にプログラミングしていきたいと思います。
手始めに、オセロ盤のマスを作りました。
言語はEmacs Lispです。

(defun Osero ()
  (let ((table nil))
  (defun initable (table sq)
    (defun initableat (table)
      (cond ((not table) (setq table '((0 0))))
	    ((= (cadr (car table)) (1- sq)) (setq table (push `(,(1+ (caar table)) 0) table)))
	    (t (setq table (push `(,(caar table) ,(1+ (cadr (car table)))) table)))
	    table))
    (defun nest (f x n)
      (let ((i 0)
	    (out x))
	(while (<= i n)
	  (setq out (funcall f out))
	  (setq i (1+ i)))
	out))
    (setq table (nest 'initableat nil (1- (* sq sq)))))))

(Osero)
initable
(initable nil 2)
((1 1) (1 0) (0 1) (0 0))

次回は、石を返すプログラムを作ろうと思います。

セルオートマトンのルール30の音

言語:mathematica

ameba[max_] := Prepend[Table[0, {i, max - 1}], 1]

rule30[x_, y_, z_] := 
 If[x == 1, (1 - y) (1 - z), (1 - (1 - y) (1 - z))]

evolveat[list_, n_, max_] := (cell = list[[n]];
  If[n == 1, leftcell = list[[max]], leftcell = list[[n - 1]]];
  If[n == max, rightcell = list[[1]], rightcell = list[[n + 1]]];
  rule30[leftcell, cell, rightcell])

evolve[list_, max_] := (Table[evolveat[list, i, max], {i, 1, max}])

main[max_] := (imogai = NestList[evolve[#, max] &, ameba[max], max];
  ArrayPlot[imogai, PixelConstrained -> 1, Frame -> False] ListPlay[
    Flatten[imogai]])

f:id:mikuwaorenoyome:20170325190214p:plain

曲は直接貼れないので、下で聞いてください
Rule30 by いえねこ | Free Listening on SoundCloud

チューリングマシン

言語:Emacs Lisp

(defun turing (input)
  (let ((tape (make-list 16 0))
	(head '(0 0))
	(prog nil))
    
    (defun readhead ()
      (elt tape (car head)))
    (defun writehead (x)
      (setf (elt tape (car head)) x))
    (defun movehead (x)
      (if (equal x 'R)
	  (setf (car head) (1+ (car head)))
	(setf (car head) (1- (car head)))))
    (defun memoryhead (x)
      (setf (cadr head) x))
    (defun printf ()
      tape)
    (defun main ()
      (setq prog input)
      (setq head '(0 0))
      (while (not (equal (cadr head) nil))
	  (dolist (x prog)
	    (if (equal (cadr head) (car x))
		(if (equal (readhead) (elt x 1))
		    (progn (writehead (elt x 3))
			   (memoryhead (elt x 4))
			   (movehead (elt x 2))))))))
    (main)
    (printf)))

謎のバグがあって、一回目の評価だけしか正しくないです。
headの初期化と関係してるっぽいけど、よくわからない・・・

(turing '((0 0 R 1 1) (1 0 R 2 nil)))
(1 2 0 0 0 0 0 0 0 0 0 0 0 0 0 0)