Import snake source.
This commit is contained in:
commit
5dfc8713f4
|
@ -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.
|
|
@ -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))
|
|
@ -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*))
|
|
@ -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)))
|
|
@ -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))
|
|
@ -0,0 +1,10 @@
|
||||||
|
#lang scribble/manual
|
||||||
|
@require[@for-label[snake
|
||||||
|
racket/base]]
|
||||||
|
|
||||||
|
@title{snake}
|
||||||
|
@author{feufochmar}
|
||||||
|
|
||||||
|
@defmodule[snake]
|
||||||
|
|
||||||
|
Package Description Here
|
Loading…
Reference in New Issue