Import snake source.

LICENSE.txt

@@ -0,0 +1,11 @@
+snake
+Copyright (c) 2019 Feufochmar
+
+This package is distributed under the GNU Lesser General Public
+License (LGPL).  This means that you can link snake into proprietary
+applications, provided you follow the rules stated in the LGPL.  You
+can also modify this package; if you distribute a modified version,
+you must distribute it under the terms of the LGPL, which in
+particular means that you must release the source code for the
+modified software.  See http://www.gnu.org/copyleft/lesser.html
+for more information.

README.md

@@ -0,0 +1,3 @@
+snake
+=====
+A little snake game.

info.rkt

@@ -0,0 +1,8 @@
+#lang info
+(define collection "snake")
+(define deps '("base" "gui"))
+(define build-deps '("scribble-lib" "racket-doc" "rackunit-lib"))
+(define scribblings '(("scribblings/snake.scrbl" ())))
+(define pkg-desc "A little snake game")
+(define version "1.0")
+(define pkg-authors '(Feufochmar))

main.rkt

@@ -0,0 +1,37 @@
+#lang racket/base
+
+(module+ test
+  (require rackunit))
+
+;; Notice
+;; To install (from within the package directory):
+;;   $ raco pkg install
+;; To install (once uploaded to pkgs.racket-lang.org):
+;;   $ raco pkg install <<name>>
+;; To uninstall:
+;;   $ raco pkg remove <<name>>
+;; To view documentation:
+;;   $ raco docs <<name>>
+;;
+;; For your convenience, we have included a LICENSE.txt file, which links to
+;; the GNU Lesser General Public License.
+;; If you would prefer to use a different license, replace LICENSE.txt with the
+;; desired license.
+;;
+;; Some users like to add a `private/` directory, place auxiliary files there,
+;; and require them in `main.rkt`.
+;;
+;; See the current version of the racket style guide here:
+;; http://docs.racket-lang.org/style/index.html
+
+;; Code here
+
+(module+ test
+  ;; Tests to be run with raco test
+  )
+
+(module+ main
+  ;; Main entry point, executed when run with the `racket` executable or DrRacket.
+  (require "private/ui.rkt")
+  (define *GUI* (make-gui-snake "tiles.png"))
+  (run-gui-snake *GUI*))

private/snake.rkt

@@ -0,0 +1,151 @@
+#lang racket/base
+
+(require
+  racket/list)
+
+(provide
+  *NORTH* *SOUTH* *EAST* *WEST*
+  +pos -pos *pos =pos
+  snake-heading snake-positions turn-snake!
+  game-snake game-preys make-game update-game! game-over?)
+
+; headings
+(define *NORTH* '(0 . -1))
+(define *SOUTH* '(0 . 1))
+(define *EAST* '(1 . 0))
+(define *WEST* '(-1 . 0))
+
+; Maths for positions
+; Null position
+(define *NULL-POS* '(0 . 0))
+; Vector addition
+(define (+pos p1 p2)
+  (cons (+ (car p1) (car p2))
+        (+ (cdr p1) (cdr p2))))
+; Vector substraction
+(define (-pos p1 p2)
+  (cons (- (car p1) (car p2))
+        (- (cdr p1) (cdr p2))))
+; Product by scalar
+(define (*pos scalar pos)
+  (cons (* scalar (car pos))
+        (* scalar (cdr pos))))
+; Equality
+(define (=pos p1 p2)
+  (and (eq? (car p1) (car p2))
+       (eq? (cdr p1) (cdr p2))))
+
+; Snake structure
+(struct snake
+  ((heading #:mutable) ; direction of the head
+   (positions #:mutable) ; positions of the snake body, as pairs of positions
+  ))
+
+; Make a snake whose head is at position head-position, going into the direction heading, and with a length of len
+(define (make-snake head-position heading len)
+  (let ((opp-heading (-pos *NULL-POS* heading)))
+    (snake
+      heading
+      (build-list
+        len
+        (lambda (x)
+          (+pos head-position (*pos x opp-heading)))))))
+
+; Move the snake
+(define (move-snake! snk)
+  (set-snake-positions!
+    snk
+    (let ((old-pos (snake-positions snk)))
+      (cons (+pos (snake-heading snk) (car old-pos))
+            (reverse (cdr (reverse old-pos)))))))
+
+; Turn the snake in the given direction, if possible
+(define (turn-snake! snk new-heading)
+  (let ((old-heading (snake-heading snk)))
+    (when
+      (or
+        (and (or (=pos old-heading *NORTH*) (=pos old-heading *SOUTH*))
+             (or (=pos new-heading *EAST*) (=pos new-heading *WEST*)))
+        (and (or (=pos old-heading *EAST*) (=pos old-heading *WEST*))
+             (or (=pos new-heading *NORTH*) (=pos new-heading *SOUTH*))))
+      (set-snake-heading! snk new-heading))))
+
+; Grow the snake by the given amount of length
+; The last position is repeated
+(define (grow-snake! snk len)
+  (let* ((old-pos (snake-positions snk))
+         (rev-old-pos (reverse old-pos)))
+    (set-snake-positions!
+      snk
+      (reverse
+        (append
+          (make-list len (car rev-old-pos))
+          rev-old-pos)))))
+
+; Check if the snake collided with itself (the head is repeated in the positions list)
+(define (snake-collided? snk)
+  (let ((pos (snake-positions snk)))
+    (member (car pos) (cdr pos) =pos)))
+
+; Check if the snake's head is outside the area
+(define (snake-fled? snk width height)
+  (let ((head (car (snake-positions snk))))
+    (or (< (car head) 0)
+        (< (cdr head) 0)
+        (<= width (car head))
+        (<= height (cdr head)))))
+
+; Add preys to a list of preys in a given area (and return the list)
+(define (add-preys preys nb width height excluded-pos)
+  (if (<= nb 0)
+      preys
+      (let ((pos (cons (random width) (random height))))
+        (if (or (member pos preys =pos) (member pos excluded-pos =pos))
+            (add-preys preys nb width height excluded-pos)
+            (add-preys (cons pos preys) (- nb 1) width height excluded-pos)))))
+
+; Make a list of preys
+(define (make-preys nb width height excluded-pos)
+  (add-preys '() nb width height excluded-pos))
+
+; Check if the snake has eaten a prey (and grow by the given amount), and return the list of preys still in the area
+(define (eat-prey! preys snk growth)
+  (let ((head (car (snake-positions snk))))
+    (if (member head preys =pos)
+        (begin
+          (grow-snake! snk growth)
+          (remove head preys =pos))
+        preys)))
+
+; Game structure
+(struct game
+  (snake
+   (preys #:mutable)
+   width
+   height
+   snake-growth))
+
+; Initialize the game
+(define (make-game width height snake-heading snake-length snake-growth nb-preys)
+  (let ((snk (make-snake (cons (floor (/ width 2)) (floor (/ height 2)))  snake-heading snake-length)))
+    (game
+      snk
+      (make-preys nb-preys width height (snake-positions snk))
+      width
+      height
+      snake-growth)))
+
+; Update the game world
+(define (update-game! gm)
+  (move-snake! (game-snake gm))
+  (set-game-preys! gm (eat-prey! (game-preys gm) (game-snake gm) (game-snake-growth gm))))
+
+; Check if the game ended, and if so, by winning or loosing
+(define (game-over? gm)
+  (cond
+    ((null? (game-preys gm))
+     'WON)
+    ((or (snake-fled? (game-snake gm) (game-width gm) (game-height gm))
+         (snake-collided? (game-snake gm)))
+     'LOST)
+    (#t #f)))

private/ui.rkt

@@ -0,0 +1,179 @@
+#lang racket/gui
+
+(require
+  "snake.rkt")
+
+(provide
+  make-gui-snake run-gui-snake)
+
+; Game constants
+(define *FRAME-WIDTH* 640)
+(define *FRAME-HEIGHT* 480)
+(define *TILE-SIZE* 16)
+(define *WIDTH* 40)
+(define *HEIGHT* 30)
+(define *SNAKE-HEADING* *NORTH*)
+(define *SNAKE-LENGTH* 3)
+(define *SNAKE-GROWTH* 2)
+(define *NB-PREYS* 20)
+
+; Canvas for drawing the game and handling keyboard events
+(define snake-canvas%
+  (class canvas%
+    (init game tiles-path)
+    (define gm game)
+    (define tiles (read-bitmap tiles-path))
+    (define timer
+      (new timer% [notify-callback
+                    (lambda ()
+                      (if (not (game-over? gm))
+                          (begin
+                            (update-game! gm)
+                            (send this refresh))
+                          (send this stop-timer)))
+                    ]))
+
+    ; Override method for keyboard events
+    (define/override (on-char event)
+      (when (not (game-over? gm))
+        (let ((snk (game-snake gm))
+              (key-code (send event get-key-code)))
+          (case key-code
+            ((up) (turn-snake! snk *NORTH*))
+            ((down) (turn-snake! snk *SOUTH*))
+            ((left) (turn-snake! snk *WEST*))
+            ((right) (turn-snake! snk *EAST*))
+            (else #f)))))
+
+    ; Draw a tile
+    (define (draw-tile dc pos tile-idx)
+      (send dc draw-bitmap-section tiles
+            (* *TILE-SIZE* (car pos)) (* *TILE-SIZE* (cdr pos))
+            (* *TILE-SIZE* (car tile-idx)) (* *TILE-SIZE* (cdr tile-idx))
+            *TILE-SIZE* *TILE-SIZE*))
+
+    ; Get the snake tile from the previous and current positions
+    (define (get-snake-tile-idx pos-2 pos-1 pos)
+      (if pos-2
+        ; Not head
+        (let ((diff-1 (-pos pos-2 pos-1))
+              (diff (-pos pos-1 pos)))
+          (cond
+            ((and (=pos diff-1 *NORTH*) (=pos diff *NORTH*)) '(0 . 2))
+            ((and (=pos diff-1 *SOUTH*) (=pos diff *SOUTH*)) '(0 . 2))
+            ((and (=pos diff-1 *EAST*) (=pos diff *EAST*)) '(1 . 2))
+            ((and (=pos diff-1 *WEST*) (=pos diff *WEST*)) '(1 . 2))
+            ((and (=pos diff-1 *EAST*) (=pos diff *SOUTH*)) '(0 . 3))
+            ((and (=pos diff-1 *NORTH*) (=pos diff *WEST*)) '(0 . 3))
+            ((and (=pos diff-1 *EAST*) (=pos diff *NORTH*)) '(1 . 3))
+            ((and (=pos diff-1 *SOUTH*) (=pos diff *WEST*)) '(1 . 3))
+            ((and (=pos diff-1 *WEST*) (=pos diff *NORTH*)) '(2 . 3))
+            ((and (=pos diff-1 *SOUTH*) (=pos diff *EAST*)) '(2 . 3))
+            ((and (=pos diff-1 *WEST*) (=pos diff *SOUTH*)) '(3 . 3))
+            ((and (=pos diff-1 *NORTH*) (=pos diff *EAST*)) '(3 . 3))
+            (#t '(1 . 0))))
+        ; Else: head
+        (let ((diff (-pos pos-1 pos)))
+          (cond
+             ((=pos diff *NORTH*) '(0 . 1))
+             ((=pos diff *EAST*) '(1 . 1))
+             ((=pos diff *SOUTH*) '(2 . 1))
+             ((=pos diff *WEST*) '(3 . 1))
+             (#t '(1 . 0))))))
+
+    ; Draw the snake tail
+    (define (draw-snake-tail dc last-pos)
+      (let* ((pos (cadr last-pos))
+             (pos-1 (car last-pos))
+             (diff (-pos pos-1 pos))
+             (tile-idx
+              (cond
+                ((=pos diff *NORTH*) '(0 . 4))
+                ((=pos diff *EAST*) '(1 . 4))
+                ((=pos diff *SOUTH*) '(2 . 4))
+                ((=pos diff *WEST*) '(3 . 4))
+                (#t '(1 . 0)))))
+        (draw-tile dc pos tile-idx)))
+
+    ; Draw the snake
+    (define (draw-snake dc)
+      (let* ((snk (game-snake gm))
+             (positions (snake-positions snk)))
+        (foldl
+          (lambda (pos old-pos) ; old-pos contain the two previous positions
+            (if old-pos
+              ; Draw the previous tile
+              (let ((tile-idx (get-snake-tile-idx (car old-pos) (cdr old-pos) pos)))
+                (draw-tile dc (cdr old-pos) tile-idx)
+                (cons (cdr old-pos) pos))
+              (cons old-pos pos)))
+          #f
+          positions)
+        (draw-snake-tail dc (reverse (take (reverse (remove-duplicates positions)) 2)))))
+
+    ; Draw the preys
+    (define (draw-preys dc)
+      (for-each
+        (lambda (pos)
+          (draw-tile dc pos '(0 . 0)))
+        (game-preys gm)))
+
+    (define *TEXT-COLOR* (make-color 255 0 0 1.0))
+    (define *TEXT-FONT* (make-font #:size 30))
+    ; Override the on-paint method for drawing canvas
+    (define/override (on-paint)
+      (let ((dc (send this get-dc)))
+        ; Clear
+        (send dc clear)
+        ; Text features
+        (send dc set-text-foreground *TEXT-COLOR*)
+        (send dc set-font *TEXT-FONT*)
+        (case (game-over? gm)
+          ((#f)
+           ; Draw snake
+           (draw-snake dc)
+           ; Draw preys
+           (draw-preys dc))
+          ((WON)
+           (call-with-values
+             (lambda () (send dc get-text-extent "GAME WON"))
+             (lambda (width height . rest)
+               (send dc draw-text "GAME WON" (/ (- *FRAME-WIDTH* width) 2) (/ (- *FRAME-HEIGHT* height) 2)))))
+          ((LOST)
+           (call-with-values
+             (lambda () (send dc get-text-extent "GAME LOST"))
+             (lambda (width height . rest)
+               (send dc draw-text "GAME LOST" (/ (- *FRAME-WIDTH* width) 2) (/ (- *FRAME-HEIGHT* height) 2))))))))
+
+    ; Start game
+    (define/public (start-timer period)
+      (send timer start period))
+
+    ; Stop game
+    (define/public (stop-timer)
+      (send timer stop))
+
+    ; Call the superclass init
+    (super-new)))
+
+; GUI structure
+(struct gui-snake
+  (frame
+   canvas
+   game))
+
+; Instanciation
+(define (make-gui-snake tiles-path)
+  (let* ((frame (new frame% [label "Snake"][width *FRAME-WIDTH*][height *FRAME-HEIGHT*]))
+         (game (make-game *WIDTH* *HEIGHT* *SNAKE-HEADING* *SNAKE-LENGTH* *SNAKE-GROWTH* *NB-PREYS*))
+         (canvas (new snake-canvas% [game game] [tiles-path tiles-path] [parent frame])))
+    (gui-snake
+      frame
+      canvas
+      game)))
+
+; Run the game
+(define (run-gui-snake gui)
+  (send (gui-snake-frame gui) show #t)
+  ; Start the timer for updating the game
+  (send (gui-snake-canvas gui) start-timer 200))

scribblings/snake.scrbl

@@ -0,0 +1,10 @@
+#lang scribble/manual
+@require[@for-label[snake
+                    racket/base]]
+
+@title{snake}
+@author{feufochmar}
+
+@defmodule[snake]
+
+Package Description Here