(def make-tetromino (typ stage) (withs ((base color) (case typ I '(((0 . 0) (1 . 0) (-1 . 0) (-2 . 0)) "#0FF") O '(((0 . 0) (1 . 0) (1 . 1) (0 . 1)) "#FF0") T '(((0 . 0) (0 . 1) (1 . 0) (-1 . 0)) "#F0F") J '(((0 . 0) (-2 . 0) (-1 . 0) (0 . 1)) "#00F") L '(((0 . 0) (0 . 1) (1 . 0) (2 . 0)) "#F70") S '(((0 . 0) (1 . 0) (0 . 1) (-1 . 1)) "#0F0") Z '(((0 . 0) (-1 . 0) (0 . 1) (1 . 1)) "#F00")) p '(4 . 0) origin (fn (p) (fn ((x . y)) (cons (+ car.p x) (+ cdr.p y)))) r idfn rotate (fn (r) (compose (fn ((x . y)) (cons y (- x))) r)) get (fn (p r) (map1 (compose origin.p r) base))) (rfn tetromino (cmd (o arg nil)) (case cmd color color get (get p r) move (let np (case arg left (cons (- car.p 1) cdr.p) right (cons (+ car.p 1) cdr.p) down (cons car.p (+ cdr.p 1))) (when (stage 'can-put? (get np r)) (= p np) t)) rotate (let nr (rotate r) (when (stage 'can-put? (get p nr)) (= r nr) t)) draw (each pn (get p r) (draw car.pn cdr.pn color)))))) (def make-stage () (withs (field {} positions (mappend (fn (y) (map1 [cons _ y] (range 0 9))) (nrev (range 0 19))) target (fn _) overflow? (fn (x y) (no (and (<= 0 x 9) (<= 0 y 19))))) (rfn stage (cmd (o o1 nil) (o o2 nil)) (case cmd can-put? (no (ccc (fn (cc) (each p o1 (when (or (overflow? car.p cdr.p) (field p)) (cc t)))))) tick (unless (do1 (target 'move 'down) (stage 'draw)) (let c (target 'color) (each p (target 'get) (= (field p) c))) (stage 'add (make-tetromino (rand-elt '(I O T J L S Z)) stage))) add (if (stage 'can-put? (o1 'get)) (= target o1) (game-over 'over)) draw (do (clear) (target 'draw) (each p positions (aif (field p) (draw car.p cdr.p it)))))))) (when (is 'over (ccc (fn (cc) (= game-over cc stage (make-stage)) ((afn (stage) (stage 'tick) (stage 'draw) (arc.time::set-timer self 800 nil stage)) stage)))) (alert "GAME OVER"))
実行