カテゴリ
全体プログラミング 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で競技プログラミングメモ帳
最新のトラックバック
ライフログ
検索
タグ
racket
その他のジャンル
ブログパーツ
最新の記事
外部リンク
ファン
記事ランキング
ブログジャンル
画像一覧
|
p. 89のDifficultです。
#lang racket
(require 2htdp/universe 2htdp/image lang/posn srfi/26) (define IMAGE-of-UFO ) (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)))))})
by tempurature
| 2015-12-15 23:51
| scheme
| ||||||||||||||||||||||
ファン申請 |
||