snake.rkt

#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)))