とりとめのないことを書いております。
by tempurature
カテゴリ
全体
プログラミング
scheme
verilog
未分類
以前の記事
2016年 04月
2016年 03月
2016年 02月
2016年 01月
2015年 12月
2015年 11月
2015年 10月
2015年 09月
2015年 08月
2015年 07月
2015年 06月
2015年 03月
お気に入りブログ
PHPで競技プログラミング
メモ帳
最新のトラックバック
ライフログ
検索
タグ
人気ジャンル
ブログパーツ
最新の記事
情報処理技術者試験 お疲れ様..
at 2016-04-17 18:55
基本情報技術者試験 平成27..
at 2016-04-14 04:48
基本情報技術者試験 平成27..
at 2016-04-13 23:03
苦い薬(ハーブ、サプリメント..
at 2016-04-09 14:03
「おバカ度チェックリスト」を..
at 2016-03-24 09:54
外部リンク
ファン
記事ランキング
ブログジャンル
画像一覧
カテゴリ:scheme( 54 )
「好きな数字ランキング」をRacketで実装してみた
#lang racket
(require rackunit)

#|
NTTドコモが2010年に「一番好きな数字ランキング」という
ランキングを実施してました。ということで、
Racketでそれを実装してみようと思いました。

[一番好きな数字ランキング]
1位:7
2位:3
3位:2
4位:8
5位:5
6位:1
7位:6
8位:4
9位:9
10位:0
ソース:http://ranking.goo.ne.jp/ranking/category/999/faction_Opr7Tu7Tgqet_all/
|#

; ソースコード
(define (number->ranking n)
  (list-ref (list 10 6 3 2 8 5 7 1 4 9) n))

(define (more-favorite? p q)
  (< (number->ranking p) (number->ranking q)))

; テストコード
(check-equal? (number->ranking 7) 1)
(check-equal? (number->ranking 3) 2)
(check-equal? (number->ranking 2) 3)
(check-equal? (number->ranking 8) 4)
(check-equal? (number->ranking 5) 5)
(check-equal? (number->ranking 1) 6)
(check-equal? (number->ranking 6) 7)
(check-equal? (number->ranking 4) 8)
(check-equal? (number->ranking 9) 9)
(check-equal? (number->ranking 0) 10)
(check-true (more-favorite? 7 2))
(check-false (more-favorite? 9 4))
(check-false (more-favorite? 5 5))


[PR]
by tempurature | 2016-01-16 10:07 | scheme
メリークリスマス! Dr. Racket!!
12/25。今日のDr. Racketの起動画面はミケランジェロの「アダムの創造」です。
キリスト生誕祭とは微妙にずれているような… なんでもないです。

c0364169_23510586.png

[PR]
by tempurature | 2015-12-25 23:51 | scheme
【racket】林先生が驚く初耳学! の結婚理論をシミュレーションで実証(n=10の場合)
前回の続きです。とりあえずソースコードから。

ソースコード

#lang racket
   
(define (for-each-permutation proc n)
  (define (req header rest)
    (if (null? rest)
        (proc (reverse header))
        (for-each
         (lambda (n)
           (req (cons (list-ref rest n) header)
                (append (take rest n) (drop rest (add1 n)))))
         (range (length rest)))))
  (req empty (range n)))

(define (let-go-and-catch perm t)
  (define tmp-top
    (if (zero? t) -1 (apply max (take (take perm t) t))))
  (define (get-point lst)
    (if (false? lst) 0 (add1 (first lst))))
  (get-point
   (memf (curryr > tmp-top) (drop perm t))))

(define (factorial n) (apply * (range 1 (+ n 1))))

(define (solve-expectation-value t n)
  (let ((sum 0))
    (for-each-permutation
     (lambda (perm) (set! sum (+ (let-go-and-catch perm t) sum))) n)
    (/ sum (factorial n))))

(define (solve-probability-of-the-best t n)
  (let ((sum 0))
    (for-each-permutation
     (lambda (perm)
       (when (= (let-go-and-catch perm t) n) (set! sum (add1 sum)))) n)
    (/ sum (factorial n))))

(define (solve-probability-not-married t n)
  (let ((sum 0))
    (for-each-permutation
     (lambda (perm)
       (when (= (let-go-and-catch perm t) 0) (set! sum (add1 sum)))) n)
    (/ sum (factorial n))))


自分が何番目の異性と結婚することができるかの期待値はsolve-expectation-value関数で算出します。0〜10の範囲のスコアで算出しています(10は一番の相手と結婚、0は未婚)。

t=0: 5.50
t=1: 7.20
t=2: 7.07
t=3: 6.48
t=4: 5.70
t=5: 4.84
t=6: 3.91
t=7: 2.96
t=8: 1.99
t=9: 1.00
t=10: 0.00

期待値だけで見た場合は、「最初の相手は見送って、2人目からは最初の人よりもいいひとなら結婚」するのがいいようです。

自分が出会う10人の人のうち、1番相性のいい人と結婚できる確率はsolve-probability-of-the-best関数で算出します。

t=0: 10.0%
t=1: 28.3%
t=2: 36.6%
t=3: 39.9%
t=4: 39.8%
t=5: 37.2%
t=6: 32.7%
t=7: 26.5%
t=8: 18.9%
t=9: 10.0%
t=10: 0.0%

1番相性のいい人と結婚したい場合、「お付き合いする人を3人見送って、4人目からはそれまでの人比べていい人なら結婚」するのがいいようです。

最後に最後まで未婚で終わってしまう確率を算出しました。

t=0: 0.0%
t=1: 10.0%
t=2: 20.0%
t=3: 30.0%
t=4: 40.0%
t=5: 50.0%
t=6: 60.0%
t=7: 70.0%
t=8: 80.0%
t=9: 90.0%
t=10: 100.0%

この結果は、上の2つに比べて単純です。例えば、1番狙いで3人見送ると未婚になる確率は30%です。1番の相手を探すのって意外にリスキーなのがわかります。


[PR]
by tempurature | 2015-12-23 14:14 | scheme
【racket】林先生が驚く初耳学! の結婚理論をシミュレーションで実証(したかったのだが…)
12/20の「林先生が驚く初耳学!」で林修さんが披露していた結婚に関する数学的考察について、シミュレーションで検証してみようと思いました。

この考察では、20歳から35歳の間に出会う人間のうち、一番自分とふさわしい相手と結婚するにはどうするのが最適か?という問題について扱っています。

ここでは、結論だけを書かせていただきますが、「20歳から35歳の間に出会う人間をn人とすると、最初に出会う(1/e)n人(つまり0.37n人)とのお付き合いでは結婚しないでおき、それ以降は、今までに付き合った人よりもいい人であれば結婚するのがよい」のだそうです。

さて、シミュレーションでは、集合{0, ..., n-1}の置換(permutation)を生成し、t人見送った時の自分と一番ふさわしい相手と結婚する確率、または自分が結婚するのが何番目の相手であるかということの期待値を算出してみます。

まず、(make-permutation n)関数を記述しました。置換のリストを出力する関数です。

>(make-permutation 3)
((0 1 2) (0 2 1) (1 0 2) (1 2 0) (2 0 1) (2 1 0))

しかし、この関数はnを多くした時にメモリを大量に消費するので、代わりに次のような関数を用意しました。

#lang racket
(require point-free)

(define (power-list l1 l2)
  (if (null? l2)
      l1
      (foldr append empty
             (map (lambda (x) (map (lambda (y) (append x y)) l2)) l1))))
   
(define (for-each-permutation proc n)
  (define (req header rest)
    (if (null? rest)
        (proc (reverse header))
        (for-each
         (lambda (n)
           (req (cons (list-ref rest n) header)
                (append (take rest n) (drop rest (add1 n)))))
         (range (length rest)))))
  (req empty (range n)))


しかし、この関数を持ってしても思った以上の計算効率が得られないようです。次のベンチマークを実行してみました。

(define (benchmark n)
  (time
   (let ((a 0))
     (for-each-permutation (lambda (x) (set! a (add1 a))) n)
   a)))


ベンチマークの実行結果です。
> (benchmark 5)
cpu time: 0 real time: 0 gc time: 0
120
> (benchmark 6)
cpu time: 0 real time: 0 gc time: 0
720
> (benchmark 7)
cpu time: 32 real time: 36 gc time: 32
5040
> (benchmark 8)
cpu time: 47 real time: 55 gc time: 31
40320
> (benchmark 9)
cpu time: 329 real time: 323 gc time: 62
362880
> (benchmark 10)
cpu time: 3141 real time: 3132 gc time: 690
3628800
> (benchmark 11)
cpu time: 36218 real time: 36340 gc time: 9431
39916800
n=10で3.1秒、n=11で36.2秒かかっています。置換の個数はn!(nの階乗)で与えられるので、n=12, 13, 14, 15のときはそれぞれ6分、78分、18時間、11日かかるものと考えられます。20歳から35歳の間に15人の相手と付き合う人もなかなかなものだと思いますが、このような場合は少し方法を変えたほうが良さそうです


[PR]
by tempurature | 2015-12-22 00:27 | scheme
【racket】lambda, cut, curryに関する演習問題
lambdaが出てきた時に、瞬時にcut, curryに置き換えられるかのトレーニングです。

Q. 以下の無名関数のそれぞれについてcut, curryに置き換えられるか答えよ。

1. (lambda (x) (* x 2))
2. (lambda (x) (- x 2))
3. (lambda (x y) (cons (* x 2) y))
4. (lambda (x) (* x x))
5. (lambda (x) (x 2))
6. (lambda (x y z) (x y z))

[閑話休題]



A.

1. cut, curryどちらも可能
(cut * <> 2)
(curry * 2)

2. cutのみ可能
(cut - <> 2)
※curryrが使えます。(curryr - 2)

3. どちらも不可
※(cut (* <> 2) <>)はエラーになる

4. どちらも不可

5. cutのみ可能
(cut <> 2)

6. cutのみ可能
(cut <> <> <>)

---

この通り、curryはcutに比べて使いづらいのですが、私なりの利点としてはこう考えています。

(lambda (x) (* x 2))を、日本語に置き換えると、「引数xをとり、xと2をかけた数を返す関数」というふうになります。

(cut * <> 2)だと、「1つの引数をとり、その引数と2をかけた値を返す関数」という意味です。

(curry * 2)で、「2をかける関数」という意味になるのだと考えます。つまり、引数を隠蔽することでより自然言語に近い表現になっているのだと思います。こういうのをポイントフリーというらしいです。
(ただ、ギリシャ時代の数学書は引数を使わないので恐ろしく理解しづらいのだが…)


[PR]
by tempurature | 2015-12-20 04:16 | scheme
【racket】REALM OF RACKET 7章を読みました
REALM OF RACKETの7章は、Land of Lambda。韻を踏んでます、ヨウチェケラッ!

ラムダは偉大なり
ラムダは偉大なり
ラムダは偉大なり

そういえば高階関数のことをタカシナカンスウと呼びたくなるのは私だけでしょうか?

The Great Lambda
The Great Lambda
The Great Lambda

7章のなかで登場する関数たち。Racketeerは手続き(procedure)のことを関数(function)というらしいです。

map
filter
ormap
andmap
foldr
foldl
build-list
apply

build-list?!
build-listはRacket特有の組み込み関数らしいです。

(build-list n proc) -> list?

> (build-list 3 add1)
'(1 2 3)
> (build-list 5 sqr)
'(0 1 4 9 16)
> (build-list 5 sqrt)
'(0 1 1.4142135623730951 1.7320508075688772 2)
> (build-list 3 +)
'(0 1 2)
> (build-list 3 *)
'(0 1 2)

この関数は、range, iotaに似ていますが、初期値とステップ数を取ることができないので使いづらいです。

+, *を受け付けますが、(build-list 3 cons)とするとさすがに怒られます。


Lambda is great
Lambda is great
Lambda is great
Lambda is great
Lambda is great

そういえばRacketのソースコードの中には画像の他に、「λ」を貼り付けることができます。でもClojureのfnのほうが名前が短いのでいいように思います。

(fn [x] (* x 2))
(fn (x) (* x 2))とはかけない。残念

lambdaの短縮形として、cutを紹介しました。
(lambda (x) (* x 2))
(cut * <> 2)

Forumで教えてもらったのですが、Racketにはcurryという組み込み関数があって、さらに短く書くことができます。

(curry * 2)

curryはいわゆるカリー化のカリーです。F#でこれを習った時は、なんて無駄機能なのだろうと思ったのですが、lambda同様、ちょっとした用で使えるようです。


[PR]
by tempurature | 2015-12-18 23:07 | scheme
【racket】REALM OF RACKET 6章の課題/Difficult
5章は、4問全て解いていましたが、6章ではDifficultだけ解いて終わりにしようと思いました。ですがソースコードを自分ごのみにリファクタリングをかけるのもおっくうに思えて、本のソースコードをちょい修正して解きました。なので、ソースコードは公開できないです。

c0364169_23524142.png

上の画像をよく見ると(このプログラムと問題に習熟している人間であれば)、バグがあることに気が付きます。

具体的には、このゲームのゲームオーバーの条件は、2つのヘビが自分か相手同士か壁にぶつかることなので、間違っています。

完成したプログラムを試していると、いきなり例外が発生したり、ゲームオーバーになったりします。特に、上の場合は対戦モードなのでデバッグがしづらくて困ります。ゲームを作るのって想像以上に難しいのだと思います。痛感させられました。


[PR]
by tempurature | 2015-12-16 23:59 | scheme
【racket】REALM OF RACKET 6章の内容
6章では、ヘビが自分にぶつからないようにして、獲物を食べていくゲームを作ります。獲物を食べるとヘビの体が大きくなります。

ソースコードは200行くらいなので、なかなかのコード効率だと思います。

c0364169_22335766.png

[PR]
by tempurature | 2015-12-16 22:35 | scheme
【racket】REALM OF RACKET 5章の課題を解いてみた(4)
p. 89のDifficultです。

#lang racket
(require 2htdp/universe 2htdp/image lang/posn srfi/26)

(define IMAGE-of-UFO 
c0364169_23484107.png




)

(define SIZE (list 300 300))
(define UFO-SIZE (map (cut <> IMAGE-of-UFO) (list image-width image-height)))
(define MARGIN 4)
(define MOVABLE
  (apply append
    (map (lambda (s us) (list (+ (quotient us 2) MARGIN)
                              (- s (quotient us 2) MARGIN)))
         SIZE UFO-SIZE)))
(define SPEED 20)

(define (draw-a-ufo-onto-an-empty-scene current-state)
  (place-image IMAGE-of-UFO (/ (first SIZE) 2) current-state
               (empty-scene (first SIZE) (second SIZE))))

(struct stat (p smokes) #:transparent)
(struct smoke (r x y) #:transparent)

(define (renew-smoke smokes)
  (cond
    [(null? smokes) empty]
    [(> (smoke-r (first smokes)) 5) (renew-smoke (rest smokes))]
    [else
      (cons
        (apply smoke
               (map (cut <> (first smokes))
                    (list (lambda (s) (add1 (smoke-r s))) smoke-x smoke-y)))
                (renew-smoke (rest smokes)))]))

(big-bang

  (stat (map (cut quotient <> 2) SIZE)
        empty)
  
  {on-key
   
    (lambda (s key)
      
      (define (smoke/offset p x y)
        (smoke 0 (+ (first p) x) (+ (second p) y)))
      
      (define (add smokes p key)
        (cond
          [(key=? key "left") (cons (smoke/offset p 15 10) smokes)]
          [(key=? key "right") (cons (smoke/offset p -15 10) smokes)]
          [(key=? key "up") (cons (smoke/offset p 0 20) smokes)]
          [(key=? key "down") (cons (smoke/offset p 0 -20) smokes)]
          [else smokes]))
      
      (define (move p key)
        (cond
          [(key=? key "left")
           (list (max (first MOVABLE) (- (first p) SPEED)) (second p))]
          [(key=? key "right")
           (list (min (second MOVABLE) (+ (first p) SPEED)) (second p))]
          [(key=? key "up")
           (list (first p) (max (third MOVABLE) (- (second p) SPEED)))]
          [(key=? key "down")
           (list (first p) (min (fourth MOVABLE) (+ (second p) SPEED)))]
          [else p]))

      (stat (move (stat-p s) key) (add (stat-smokes s) (stat-p s) key)))}

  {on-tick
    (lambda (s)
      (stat (stat-p s) (renew-smoke (stat-smokes s))))
    0.075}
  
  {to-draw
    (lambda (s)
      (place-images/align
        (map (lambda (smk) (circle (smoke-r smk) "outline" "gray"))
             (stat-smokes s))
        (map (lambda (smk) (make-posn (smoke-x smk) (smoke-y smk)))
             (stat-smokes s))
        "center" "center"
        (place-image IMAGE-of-UFO (first (stat-p s)) (second (stat-p s))
                     (empty-scene (first SIZE) (second SIZE)))))})


[PR]
by tempurature | 2015-12-15 23:51 | scheme
【racket】REALM OF RACKET 5章の課題を解いてみた(3)
p. 89のMediamです。the number of guessesは、推測回数という意味らしいです。


#lang racket

(require 2htdp/universe 2htdp/image)

(struct stat (small big count))

(define WIDTH 600)
(define HEIGHT 300)
(define TEXT-X 100)
(define TEXT-UPPER-Y 50)
(define TEXT-LOWER-Y 250)

(define (app-text body #:size [size 20] #:color [color "blue"])
  (text body size color))

(define HELP-TEXT
  (app-text "↑ for larger numbers, ↓ for smaller ones"))
(define HELP-TEXT2
  (app-text "Press = when your number is guessed; q to quit."))

(define MT-SC
  (place-image/align
   HELP-TEXT TEXT-X TEXT-UPPER-Y "left" "top"
   (place-image/align
    HELP-TEXT2 TEXT-X TEXT-LOWER-Y "left" "bottom"
    (empty-scene WIDTH HEIGHT))))

(define (smaller w)
  (stat (stat-small w)
        (max (stat-small w) (sub1 (guess w)))
        (add1 (stat-count w))))

(define (bigger w)
  (stat (min (stat-big w) (add1 (guess w)))
        (stat-big w)
        (add1 (stat-count w))))

(define (guess w)
  (quotient (+ (stat-small w) (stat-big w)) 2))


(define (start lower upper)
  (big-bang
   
   (stat lower upper 1) ; init
   
   {on-key
     (lambda (s key)
       (case key [("up") (bigger s)]
                 [("down") (smaller s)]
                 [("=") (stop-with s)]
                 [("q") (stop-with s)]
                 [else s]))}
   
   {to-draw
     (lambda (s)
       (overlay
         (app-text (number->string (guess s)) #:color "red" #:size 100)
       (overlay/offset
         (app-text (string-append "trial " (number->string (stat-count s))))
         -200 0
         MT-SC)))}
   
   {stop-when
     (lambda (s)
       (= (stat-small s) (stat-big s)))
     (lambda (s)
       (overlay
         (app-text "End" #:color "red" #:size 100)
         (overlay/offset
           (app-text (string-append "trial " (number->string (stat-count s))))
           -200 0
           MT-SC)))}))


[PR]
by tempurature | 2015-12-15 20:56 | scheme