とりとめのないことを書いております。
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
外部リンク
ファン
記事ランキング
ブログジャンル
画像一覧
タグ:Racket ( 45 ) タグの人気記事
【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
【racket】3つの円がぐるぐる回るアニメーション
big-bangを使って、3つの円がぐるぐる回るアニメーションを作りました。

最初は、map, fold, set!やパラメータを使って書いてましたが、コードの見た目がすっきりしなかったので、ハードコーディングで書き直しました。実行効率も、頑張ってmutableにしてみたものとあまり変わらず、むしろ関数が少ない分効率がいいです。

とはいえ、Dr. Racketの動かし方で、GCが沢山動く場合があります。RacketでGUIを動かすのは難しいのかもしれません。

[スナップショット]

c0364169_22223215.png

[ソースコード]

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

(struct stat (cnt red blue yellow))

(define RAD-UNIT (* 2.0 pi))
(define DEGREE (/ RAD-UNIT 360.0))

(define (start)
  (big-bang
    (stat 0 (* 0.0 DEGREE) (* 30.0 DEGREE) (* 60.0 DEGREE))

    {on-tick
      (lambda (s)
        (stat (add1 (stat-cnt s))
              (+ (stat-red s) (* 10.0 DEGREE))
              (+ (stat-blue s) (* 5.0 DEGREE))
              (+ (stat-yellow s) (* 7.5 DEGREE))))}

    {on-draw
      (lambda (s)
        (place-images/align
          (list (circle 20 "solid" "red")
                (circle 12 "solid" "blue")
                (circle 18 "solid" "yellow"))
          (list (make-posn (+ (* (cos (stat-red s)) 100) 250)
                           (+ (* (sin (stat-red s)) 100) 250))
                (make-posn (+ (* (cos (stat-blue s)) 50) 250)
                           (+ (* (sin (stat-blue s)) 50) 250))
                (make-posn (+ (* (cos (stat-yellow s)) 150) 250)
                           (+ (* (sin (stat-yellow s)) 150) 250)))
          "center" "center"
          (empty-scene 500 500)))}

    {stop-when
      (lambda (s)
        (>= (stat-cnt s) 200))}))


[PR]
by tempurature | 2015-12-13 22:23 | scheme
【racket】パイプ/メソッドチェーンを作る
シェルプログラミングにおいては、しばしばパイプ( | )を使用して、複数のコマンドを連結して使います。

[パイプの例]

・ディレクトリのファイルの個数を数える
ls | wc

・カレントディレクトリと下位階層のファイルのうち、ファイル内に特定の文字列が含まれているものを探す
find . | xargs grep ABC

・sedをデバッグする
echo "Good Morning!!" | sed -r 's/Morn/Even/g'


javascriptやrubyでは、これと同様に関数を直列に連結して「メソッドチェーン」を作成することがままあります。

また、F#やElixirにはパイプライン演算子( |> )が用意されており、まさに処理を多段にすることができます。

Clojureにおいては、スレッドマクロ( -> )が用意されており、これもパイプライン演算子と同様の動作をするようです。


さて、racketにおいては、追加モジュールでパイプのようなものが用意されています。rackjureモジュールとpoint-freeモジュールそれぞれで用意されており、少し動作が異なります。

[導入方法]
コマンドラインで以下のコマンドを入力します。
raco pkg install rackjure
raco pkg install point-free

[パイプラインを使用しないソースコード]
racketドキュメントのコードを引用しています。

#lang racket
(require 2htdp/image)

(place-image
   (circle 4 "solid" "white")
   18 20
   (place-image
    (circle 4 "solid" "white")
    0 6
    (place-image
     (circle 4 "solid" "white")
     14 2
     (place-image
      (circle 4 "solid" "white")
      8 14
      (rectangle 24 24 "solid" "goldenrod")))))

このコードでは、処理は後ろの行から前に流れていきます。

[パイプラインを使用したソースコード]

#lang racket
(require 2htdp/image point-free srfi/26)

(~> (rectangle 24 24 "solid" "goldenrod")
    (cut place-image (circle 4 "solid" "white") 8 14 <>)
    (cut place-image (circle 4 "solid" "white") 14 2 <>)
    (cut place-image (circle 4 "solid" "white") 0 6 <>)
    (cut place-image (circle 4 "solid" "white") 18 20 <>))

このコードでは、処理は前から後ろに流れていきます。こちらのほうが分かりやすいと感じられますし、括弧(入れ子)の数が減るので、修正したりするのも楽です。


[PR]
by tempurature | 2015-12-13 04:05 | scheme
【racket】cutを使うには?
Gaucheでは、cutはlambdaの短縮記法として標準的に使うことができます。
cutは、SRFI 26というschemeの追加仕様で規定されているので、racketでもモジュールロードによって使用することができます。

#lang racket
(require srfi/26)

> (map (cut + <> 5) '(1 2 3 4 5))
'(6 7 8 9 10)

racketにはcutの他にも、SRFIの追加モジュールが用意されているようです。



[PR]
by tempurature | 2015-12-13 01:37 | scheme
【racket】REALM OF RACKET 5章を解いてみた(2)
(前投稿の続き)Easyの後半も解きました。

#lang racket
(require 2htdp/universe 2htdp/image)

(define LOCOMOTIVE ...)

(define WIDTH 800)
(define HEIGHT 100)
(define IMG-WIDTH (image-width LOCOMOTIVE))
(define IMG-HEIGHT (image-height LOCOMOTIVE))
(define T-MAX (+ WIDTH 1))

(big-bang
  -30 ; init
          
  {on-tick
    (lambda (t) (+ t 3))}
  
  {on-draw
    (lambda (t)
      (foldl (lambda (x y) (x y))
        (empty-scene WIDTH HEIGHT) ; bottom layer
        {list
          (lambda (prev)
            (place-image/align LOCOMOTIVE
                               (max t 1) (/ HEIGHT 2)
                               "left" "center"
                               prev))
          (lambda (prev)
            (place-image/align LOCOMOTIVE
                               (- t WIDTH) (/ HEIGHT 2)
                               "left" "center"
                               prev))}))}

  {stop-when
    (lambda (t) (>= t T-MAX))}
  )


[PR]
by tempurature | 2015-12-10 23:20 | scheme
【racket】REALM OF RACKET 5章の課題を解いてみた(1)
REALM OF RACKET p.89 Chapter ChallengesのEasyを解きました。

【問題】
Find an image of a locomitive. Create an animation that runs the locomotive from just past the left margin to just past the right margin of the screen. Next, modify your program so the locomotive wraps around to the left side of the screen after passing the right margin.

(拙訳) 蒸気機関車の画像を探してください。次に、画面の左端から右端まで蒸気機関車が走るアニメーションを作ってください。また、右端まで来た時に左端に戻るよう修正してください。

※この記事では、問題の前半だけ扱います。

【蒸気機関車の画像】
私が描いた絵です。
c0364169_22285551.png






【ソースコード1】
画面の左端から右端まで蒸気機関車が走るアニメーション

#lang racket
(require 2htdp/universe 2htdp/image)

(define LOCOMOTIVE )

(define WIDTH 800)
(define HEIGHT 100)
(define IMG-WIDTH (image-width LOCOMOTIVE))
(define IMG-HEIGHT (image-height LOCOMOTIVE))
(define T-MAX (- WIDTH IMG-WIDTH 1))

(big-bang
  -30 ; init
          
  {on-tick
    (lambda (t) (+ t 3))}
  
  {on-draw
    (lambda (t)
      (place-image/align LOCOMOTIVE
                         (max 1 (min t T-MAX)) (/ HEIGHT 2)
                         "left" "center"
                         (empty-scene WIDTH HEIGHT)))}

  {stop-when
    (lambda (t) (>= t T-MAX))}
  )

【スナップショット】
c0364169_22330509.png
ヘタレ絵がゆっくり進むので、地味に和みます。


[PR]
by tempurature | 2015-12-10 22:42 | scheme
【racket】12月10日はエイダ・ラブレスの誕生日
Dr. Racketの起動画面で、いつもと違うのが出てきたのは、2回目です。

c0364169_21103297.png
私もAdaやってみたいと思うのですが、日本語の情報が少ないのとスピード感がないのとでちょっと辛くて断念しました。

プログラマのエイダさんについてはあまり存じてないのでなんとも。どこぞのLisperとは違って高貴な方でいらしたのだと思います…ていったらPLTにおこられるのか。めんご。


[PR]
by tempurature | 2015-12-10 21:18 | scheme
【racket】REALM OF RACKET 5章まで読みました
5章では、2htdp/universeモジュールを使って、2つのGUIプログラムを作成します。

c0364169_22544731.png
Landing a UFO

UFOの画像が着陸するアニメーションを作成します。
(UFOの絵は私が書きました)

c0364169_22582545.png
Guessing Gooey

2章で作成したGuess My Number GameのGUI版です。

他のプログラミング本でも言えることなのですが、ソースコードを小出しにして説明していき、どっかこっかが抜けているという初心者泣かせの記述になっています。大丈夫、CとJavaができれば問題ないさっ!emoticon-0165-muscle.gif


2htdp/universeはよく出来たモジュールだと思います。下記ドキュメントのリンクをざっと目で追ってみてください。


[PR]
by tempurature | 2015-12-09 23:10 | scheme
【racket】Shift-JIS → EUC-JP に変換するスクリプト
改行コードは変えてません。


#!/usr/local/bin/racket

#lang racket

(current-locale "jp")

(define convert (bytes-open-converter "SHIFT_JIS" "EUC-JP"))

(define q '())

(let loop ([b (read-byte)])
  (unless (eq? b eof)
    (set! q (cons b q))
    (let-values ([(res num stat)
                  (bytes-convert convert (list->bytes (reverse q)))])
      ;(newline)
      (cond [(equal? res 0) (void)]
            [(= num 0) (void)]
            [(eq? stat 'complete)
             (write-bytes res)
             (set! q '())]
            [(or (eq? stat 'continues) (eq? stat 'aborts))
             (void)]
            [(eq? stat 'error)
             (write "?")
             (set! q '())]
            [else (write stat (current-error-port)) (error "ERROR")])
      (loop (read-byte)))))

(flush-output)
(bytes-close-converter convert)


[PR]
by tempurature | 2015-12-09 01:10 | scheme