Last active
July 9, 2018 03:47
-
-
Save lexi-lambda/eaed4331c58d3a8be1ea5ea5ecf4b5ec to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
#lang hackett | |
(require (only-in racket/base for-syntax begin) | |
(for-syntax racket/base | |
racket/list | |
racket/syntax) | |
threading | |
syntax/parse/define | |
hackett/demo/pict | |
hackett/demo/pict/universe) | |
(def init! : (forall [a] {(List a) -> (List a)}) | |
{reverse . tail! . reverse}) | |
(define-simple-macro (defrecord record-type | |
(record-constructor [field-name:id field-type] ...+) | |
opt ...) | |
#:with [defns ...] | |
(let loop ([pre-fields '()] | |
[other-fields (attribute field-name)]) | |
(if (empty? other-fields) '() | |
(let* ([field (first other-fields)] | |
[post-fields (rest other-fields)] | |
[set-field-name (format-id field "set-~a" field | |
#:source field #:props field)] | |
[update-field-name (format-id field "update-~a" field | |
#:source field #:props field)]) | |
(cons | |
#`(begin | |
(defn #,field | |
[[(record-constructor field-name ...)] #,field]) | |
(defn #,set-field-name | |
[[v (record-constructor field-name ...)] | |
(record-constructor #,@(reverse pre-fields) v #,@post-fields)]) | |
(defn #,update-field-name | |
[[f x] (#,set-field-name (f (#,field x)) x)])) | |
(loop (cons field pre-fields) post-fields))))) | |
(begin | |
(data record-type (record-constructor field-type ...) opt ...) | |
defns ...)) | |
(data Point (Point Integer Integer) | |
#:deriving [Eq Show]) | |
(data Direction D:Left D:Right D:Up D:Down | |
#:deriving [Eq Show]) | |
(defn move : {Direction -> Point -> Point} | |
[[D:Left (Point x y)] (Point {x - 1} y)] | |
[[D:Right (Point x y)] (Point {x + 1} y)] | |
[[D:Up (Point x y)] (Point x {y - 1})] | |
[[D:Down (Point x y)] (Point x {y + 1})]) | |
(defrecord World-State | |
(World-State [snake-direction Direction] | |
[snake-blocks (List Point)] | |
[food-blocks (List Point)]) | |
#:deriving [Show]) | |
(def board-width 50) | |
(def board-height 30) | |
(def tile->absolute {(d* 15.0) . integer->double}) | |
(def empty-board (blank-rect (tile->absolute board-width) (tile->absolute board-height))) | |
(def block (filled-square 13.0)) | |
(def food-block (colorize red block)) | |
(def snake-block (colorize black block)) | |
(defn render-on-board : {Pict -> (List Point) -> Pict} | |
[[pict points] | |
(foldr (λ [(Point x y) acc] | |
(pin-over acc (tile->absolute x) (tile->absolute y) pict)) | |
empty-board points)]) | |
(defn render : {World-State -> Pict} | |
[[(World-State _ snake-points food-points)] | |
(pin-over (render-on-board snake-block snake-points) | |
0.0 0.0 | |
(render-on-board food-block food-points))]) | |
(def random-point : (IO Point) | |
{Point <$> (random-integer 0 board-width) | |
<*> (random-integer 0 board-height)}) | |
(defn on-tick : {World-State -> (IO World-State)} | |
[[(World-State dir snake-points food-points)] | |
(let ([new-snake-point (move dir (head! snake-points))]) | |
(if {new-snake-point elem? food-points} | |
(do [new-food-point <- random-point] | |
(pure (World-State dir | |
{new-snake-point :: snake-points} | |
{new-food-point :: (delete new-snake-point food-points)}))) | |
(pure (World-State dir {new-snake-point :: (init! snake-points)} food-points))))]) | |
(defn on-key : {Key-Event -> World-State -> (IO World-State)} | |
[[KE:Left ] {pure . (set-snake-direction D:Left)}] | |
[[KE:Right] {pure . (set-snake-direction D:Right)}] | |
[[KE:Up ] {pure . (set-snake-direction D:Up)}] | |
[[KE:Down ] {pure . (set-snake-direction D:Down)}] | |
[[_ ] {pure . id}]) | |
(def initial-state | |
(do [initial-food <- (sequence (take 5 (repeat random-point)))] | |
(pure (World-State D:Right | |
(List (Point 25 15) (Point 24 15) (Point 23 15)) | |
initial-food)))) | |
(main (do [state <- initial-state] | |
(big-bang state | |
#:to-draw render | |
#:on-tick on-tick 0.2 | |
#:on-key on-key))) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment