DouKaku? Language detail: Arc

LL Golf Hole 2 - 文字列に含まれる単語の最初の文字を大文字にする (Nested Flatten)

もうちょっと頑張ってみました。
実行例:
arc> (c "LL day and night")
LL Day And Night("LL" "Day" "And" "Night")

表示の「("LL" 〜」以降は prall(出力関数)の返り値なので気にしないでください。

1	(def c(x)(prall(map[do(=(_ 0)(upcase:_ 0))_](tokens x))"" " "))

戦略はいたってシンプルで、
・文字列を単語毎に分ける
・単語の頭を大文字にする
・単語をつなげる
というかんじです。

1	(def c(x)(prn:apply +(intersperse" "(map(fn(y)(=(y 0)(upcase:y 0))y)(tokens x)))))

マルバツゲーム：賢いプレイヤー (Nested Flatten)

先攻の場合は、リーチされてなければ、できるだけ角を取ってダブルリーチを狙う戦略です。
後攻の場合は、相手の初手に合わせて戦略を変えています。
思った以上の勝率でちょっとビックリしました。

実行結果:
arc> (nplay-ox 10000 smart-player)
smart-player win: 9919
random-player win: 0
draw: 81
nil

arc> (nplay-ox 10000 random-player)
smart-player win: 8428
random-player win: 0
draw: 1572
nil

(= lines '((1 2 3) (1 4 7) (1 5 9) (2 5 8) (3 5 7) (3 6 9) (4 5 6) (7 8 9)))

(def lsets<= (s1 s2) (all [mem _ s2] s1))

(def reach? (line mark pool)
  (let marked (map [if (mem _ mark) t nil] line)
    (if (and (is (count nil marked) 1) (mem (line (pos nil marked)) pool))
          (line (pos nil marked))
        nil)))

(def random-player (smark rmark pool)
  (if (is pool nil) 'd
      (withs (picked (random-elt pool) rm (cons picked rmark) rp (rem picked pool))
        (if (some [lsets<= _ rm] lines) 'r
            (smart-player smark rm rp)))))

(def smart-player (smark rmark pool)
  (if (is pool nil) 'd
      (let rr (rem nil (map [reach? _ rmark pool] lines))
        (if (isnt nil (rem nil (map [reach? _ smark pool] lines))) 's
            (isnt nil rr) (random-player (cons (car rr) smark) rmark (rem (car rr) pool))
            (odd (len pool)) (senkou smark rmark pool)
            (koukou smark rmark pool)))))

(def senkou (smark rmark pool)
  (if (is (len pool) 9) (random-player (cons 1 smark) rmark (rem 1 pool))
      (is (len pool) 7)
        (let m (if (lsets<= '(2 3) pool) 3 7)
          (random-player (cons m smark) rmark (rem m pool)))
      (is (len pool) 1) 'd
      (let m (if (lsets<= '(4 7) pool) 7 9)
        (random-player (cons m smark) rmark (rem m pool)))))

(def koukou (smark rmark pool)
  (let rf (last rmark)
    (if (mem rf '(1 3 7 9))
          (pat1379 smark rmark pool)
        (mem rf '(2 4))
          (pat24 smark rmark pool)
        (mem rf '(6 8))
          (pat68 smark rmark pool)
        (pat5 smark rmark pool))))

(def pat1379 (smark rmark pool)
  (if (is (len pool) 8) 
        (random-player (cons 5 smark) rmark (rem 5 pool))
      (is (len pool) 6)
        (let m (if (some [mem _ rmark] '(2 6)) 3
                   (some [mem _ rmark] '(4 8)) 7 2)
          (random-player (cons m smark) rmark (rem m pool)))
      (is (len pool) 4)
        (let m (if (some [mem _ rmark] '(2 8)) 4 2)
          (random-player (cons m smark) rmark (rem m pool)))
      (let picked (random-elt pool)
        (random-player (cons picked smark) rmark (rem picked pool)))))

(def pat24 (smark rmark pool)
  (if (is (len pool) 8)
        (random-player (cons 1 smark) rmark (rem 1 pool))
      (is (len pool) 6)
        (let m (if (lsets<= '(2 9) rmark) 7
                   (lsets<= '(4 9) rmark) 3 5)
          (random-player (cons m smark) rmark (rem m pool)))
      (is (len pool) 4)
        (let m (if (lsets<= '(2 4 9) rmark) (if (mem 5 pool) 5 (mem 3 pool) 3 7)
                   (lsets<= '(2 5 9) rmark) 7
                   (lsets<= '(5 4 9) rmark) 3)
          (random-player (cons m smark) rmark (rem m pool)))
      (let picked (random-elt pool)
        (random-player (cons picked smark) rmark (rem picked pool))))))

(def pat68 (smark rmark pool)
  (if (is (len pool) 8)
        (random-player (cons 9 smark) rmark (rem 9 pool))
      (is (len pool) 6)
        (let m (if (lsets<= '(1 6) rmark) 7
                   (lsets<= '(1 8) rmark) 3 5)
          (random-player (cons m smark) rmark (rem m pool)))
      (is (len pool) 4)
        (let m (if (lsets<= '(1 6 8) rmark) (if (mem 5 pool) 5 (mem 3 pool) 3 7)
                   (lsets<= '(1 5 8) rmark) 3
                   (lsets<= '(1 5 6) rmark) 7)
          (random-player (cons m smark) rmark (rem m pool)))
      (let picked (random-elt pool)
        (random-player (cons picked smark) rmark (rem picked pool))))))

(def pat5 (smark rmark pool)
  (if (is (len pool) 8) 
        (random-player (cons 1 smark) rmark (rem 1 pool))
      (is (len pool) 6)
        (random-player (cons 3 smark) rmark (rem 3 pool))
      (let picked (random-elt pool)
        (random-player (cons picked smark) rmark (rem picked pool)))))

(def nplay-ox (n sente)
  (let wl (map (fn (_) (sente nil nil (range 1 9))) (range 1 n))
    (prn "smart-player win: " (count 's wl))
    (prn "random-player win: " (count 'r wl))
    (prn "draw: " (count 'd wl))
    nil))

マルバツゲーム (Nested Flatten)

srfi-1 の lset<= もどきを自作。

実行結果:
arc> (nplay-ox 10000)
o win: 5835
x win: 2889
draw: 1276
nil

(def lset<= (s1 s2)
  (if (is s1 nil) t
      (mem (car s1) s2) (lset<= (cdr s1) s2)
      nil))

(def check (lis)
  (when (< (len lis) 3) nil)
  (or (lset<= '(1 2 3) lis)
      (lset<= '(1 4 7) lis)
      (lset<= '(1 5 9) lis)
      (lset<= '(2 5 8) lis)
      (lset<= '(3 5 7) lis)
      (lset<= '(3 6 9) lis)
      (lset<= '(4 5 6) lis)
      (lset<= '(7 8 9) lis)))

(def o-player (omark xmark pool)
  (withs (picked (random-elt pool)
          om (cons picked omark))
    (if (check om) 'o
        (is (cdr pool) nil) 'd
        (x-player om xmark (rem picked pool)))))

(def x-player (omark xmark pool)
  (withs (picked (random-elt pool)
          xm (cons picked xmark))
    (if (check xm) 'x
        (o-player omark xm (rem picked pool)))))

(def nplay-ox (n)
  (let wl (map (fn (_) (o-player nil nil (range 1 9))) (range 1 n))
    (prn "o win: " (count 'o wl))
    (prn "x win: " (count 'x wl))
    (prn "draw: " (count 'd wl))
    nil))

文字列のセンタリング (Nested Flatten)

実行例:
arc> (centering "hoge" 10)
" hoge "
arc> (centering "hogefuga" 5)
"ogefu"

(def mklist (n (o fill nil)) (map (fn (x) fill) (range 1 n)))

(def centering (str length)
  (withs (plen (- length (len str)) tlen (abs plen) l (trunc (/ tlen 2)) r (- tlen l))
    (if (positive plen)
        (string (mklist l #\space) str (mklist r #\space))
        (cut str l (- (len str) r)))))

立方根の計算 (Nested Flatten)

整数部分は配列(リスト)のインデックスで、小数部分は二分探索的なアプローチで求めています。
三乗根がピッタリ整数の場合は、整数で答えを出すようにしたので、ちょっと長くなりました。

実行例:
arc> (search-cube-root 10.0)
2.1544346900318487
arc> (expt (search-cube-root 10.0) 3)
9.999999999999513
arc> (search-cube-root 100.0)
4.641588833612786
arc> (expt (search-cube-root 100.0) 3)
100.00000000000048
arc> (search-cube-root 125.0)
5

(= cube-list (map [expt _ 3] (range 1 10)))
(= acc 0.000000000001)

(def search-real (cr of rn)
  (let gosa (- rn (expt cr 3))
    (if (< (abs gosa) acc)
        cr
        (if (< 0 gosa)
            (search-real (+ cr of) (/ of 2) rn)
            (search-real (- cr of) (/ of 2) rn)))))

(def search-cube-root (rn)
  (if (is (type rn) 'int)
      (let i (trunc rn)
        (if (mem i cube-list)
            (+ (pos i cube-list) 1)
            (search-real (+ (pos i (sort < (cons i cube-list))) 0.5) 0.25 rn)))
      (search-real (+ (pos rn (sort < (cons rn cube-list))) 0.5) 0.25 rn)))

水の移し替えパズル (Nested Flatten)

その必要はないと知りつつも、律儀に水を移し替える実装にしてみました。
問題が解決できない(水量の差が 3 の倍数である容器の組が存在しない)場合は nil を返して終了します。

実行例:
arc> (mizu '(4 2 10))
10
arc> (mizu '(827392 65536 122880))
827392
arc> (mizu '(5 7 9))
nil

水が移動する様を見たい方は 9 行目の (prn w) をアンコメントしてください。

(def mizu (waters)
  (let index (indexing waters)
    (if (is index nil) nil
        (with (lcr '((2 -1 -1) (-1 2 -1) (-1 -1 2))
               n1 (index 0)
               n2 (index 1)
               aw (index 2))
          ((rfn lp (w step)
;            (prn w)
             (if (is (w n1) (w n2) 0) step
                 (is (w n1) 0) (lp (map + (lcr n1) w) (+ step 1))
                 (< (w aw) (/ (- (w n2) (w n1)) 3)) (lp (map + (lcr aw) w) (+ step 1))
                 (isnt (w n2) (w n1)) (lp (map + (lcr n1) w) (+ step 1))
                 (lp (map + (lcr aw) w) (+ step 1))))
           waters 0)))))

(def indexing (ls)
  (withs (mm (map [pos _ ls] (sort < ls))
          min (ls (mm 0))
          mid (ls (mm 1))
          max (ls (mm 2)))
    (if (is 0 (mod (- mid min) 3)) (list (mm 0) (mm 1) (mm 2))
        (is 0 (mod (- max min) 3)) (list (mm 0) (mm 2) (mm 1))
        (is 0 (mod (- max mid) 3)) (list (mm 1) (mm 2) (mm 0))
        nil)))

アルファベットの繰り上がり (Nested Flatten)

似たような機能にはrangeがあるようです。
私も以前に自作したiotaを投稿してから気づいた
のですが…^^;

Arc にも iota みたいなのが欲しい。

実行例:
arc> (make-alnum-list 100)
(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z AA AB AC AD AE AF AG AH AI AJ AK AL AM AN AO AP AQ AR AS AT AU AV AW AX AY AZ BA BB BC BD BE BF BG BH BI BJ BK BL BM BN BO BP BQ BR BS BT BU BV BW BX BY BZ CA CB CC CD CE CF CG CH CI CJ CK CL CM CN CO CP CQ CR CS CT CU CV)

(def dec-to-ib26-list (x)
  ((rfn lp (x ret)
     (if (is 0 x) ret
         (< (/ x 26) 1) (cons x ret)
         (is (type (/ x 26)) 'int) (lp (- (/ x 26) 1) (cons 26 ret))
         (lp (trunc (/ x 26)) (cons (mod x 26) ret))))
   x nil))

(def to-alnum (x)
  (apply string (map [coerce (+ _ 64) 'char] (dec-to-ib26-list x))))

(def iota (x . z)
  (with (limit x
         start (if (car z) (car z) 0)
         step  (if (cadr z) (cadr z) 1))
    (rev (let x nil (repeat limit (do (push start x) (++ start step))) x))))

(def make-alnum-list (n)
  (map [coerce (to-alnum _) 'sym] (iota n 1 1)))

議席数をドント方式で (Nested Flatten)

ちょっと手直し。

(def donto (pool votes)
  (with (ls (let x nil (repeat (len votes) (push 0 x)) x)
          v (copy votes))
    (repeat pool
      (let i (pos (apply max v) v)
        (= (v i) (/ (votes i) (+ 1 (++ (ls i)))))))
    ls))

実行例:
arc> (donto 100 '(123 4 56 78))
(48 1 21 30)

2 行目の (let x ...) は scheme でいう (make-list ...)
の代替。

(def donto (pool votes)
  (with (ls (let x nil (repeat (len votes) (push 0 x)) x)
          v (copy votes))
    ((rfn lp (p)
       (if (is 0 p)
           ls
           (let i (pos (apply max v) v)
             (= (v i) (/ (votes i) (+ 1 (++ (ls i)))))
             (lp (- p 1)))))
     pool)))

音声合成でHello, world! (Nested Flatten)

MacOSXのsayコマンドに文字列を渡しています。
(say "Hello, world!")

1
2
3

(def say (mesg)
 (system (+ "say " mesg "&")) 
 mesg)

文字変換表に基く文字列の変換 (Nested Flatten)

UNIXのtrコマンドや、Perlのtr演算子のように、指定した対応づけに従って文字を変換する関数を作成して下さい。
予め言語内に用意されている場合は、(1)一般的な使用法と、(2)より進んだ使用方法を提示して下さい。

'ABCDEF'と'abcdef'等すべて対応する文字を書く必要があるものを、(1)基本版、'A-Z'と'a-z'のように"-"で範囲を指定できるものを(2)拡張版、2を更に発展させたものを(3)発展版とします。任意のものを選んで解答して下さい。

実行例. (与えられた文字列が、"typewriter"の場合)
tr 'qwertyuiop' 'QWERTYUIOP' "typewriter"
=> TYPEWRITER

;; 基本版/Arc
(def tr (orig subst str)
  (tostring
   (each c str
     (pr (aif (pos c orig) (subst it) c)))))

(tr "qwertyuiop" "QWERTYUIOP" "typewriter")
;=>"TYPEWRITER"

n人中m人が当選するくじ (Nested Flatten)

Arcです。
お題46の「重複無し乱数」で定義したbingoを使用しています。
(lot 999 4)
;=> (484 286 880 186)
;...
;=> (699 151 312 134)

see: bingo

1 2	(def lot (n m) (firstn m (bingo n)))

重複する要素を取り除く (Nested Flatten)

Arcです。
[]記法が使えるのを忘れてました。短いのは良いとは思えど…。

1 2	(def uniq-only (lst) (rem [mem _ (cdr:mem _ lst)] lst))

アレイのuniq (Nested Flatten)

Arcです。
Arcでは、dedupがお題と同じ動作をするようです。

1 2	(dedup '(3 1 4 1 5 9 2 6 5 3 5 8 9 7 9)) ;=> (3 1 4 5 9 2 6 8 7)

重複する要素を取り除く (Nested Flatten)

Arcです。
(uniq-only '(3 1 4 1 5 9 2 6 5))
;=> (3 4 9 2 6)

1
2
3

(def uniq-only (lst)
  (rem (fn (item) (mem item (cdr:mem item lst))) 
       lst))

文字列の反転 (Nested Flatten)

Arcです。文字の扱いについては色々議論されているようですが…。
今のところrevは文字列の反転には使えないようですね…。
リストにして反転して文字列に直しています。
;;
arc> (srev "こんにちは")
"はちにんこ"

arc> (srev "濁点(だくてん)")
")んてくだ(点濁"

1
2
3

(def srev (str)
  (let chars (coerce str 'cons)
    (string (rev chars))))

重複無し乱数 (Nested Flatten)

Arcです。
割とCommon Lispみたいになってしまいました。

(def bingo (n)
  (let lst (iota n 1)
    (for i 0 (- n 1)
      (swap (lst i) (lst (rand n))))
    lst))

(def iota (n (o start 0) (o step 1))
  (let res ()
    (repeat n
      (push start res)
      (++ start step))
    (rev res)))

コラッツ・角谷の問題 (Nested Flatten)

Arcです。
Core2 Duo E6600/Linux 2^20で6分位です。
定義をメモ化できるdefmemoってのがあるので、それを使ってみたんですが、
自分はあまり上手く使いこなせていないようで、スピードがでません…。
実行結果
(time (collatz-max (expt 2 20)))
;=>
;time: 334690 msec.
;"f(837799) = 524"

(def collatz-max (num)
  ((afn (num i n highest)
    (if (> i num)
        (prn (string "f(" n ") = " highest))
        (let cur (collatz i)
          (if (< highest cur)
          (self num (+ i 1) i cur)
          (self num (+ i 1) n highest)))))
   num 1 0 0))

(defmemo collatz (n)
  ((afn (res cnt)
    (if (is res 1)
        cnt
        (self (if (even res)
              (/ res 2)
              (+ (* res 3) 1))
          (+ cnt 1))))
   n 0))

DouKaku?

Language detail: Arc

Unsolved challenges

codes

Index

Feed

Other

Link

Pathtraq