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