Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

object-list, update, move ...

  • Loading branch information...
commit 79a46170612cb32eb1eaa13392005dba1dc82530 1 parent b6e8588
Benjamin Lind authored
Showing with 273 additions and 12 deletions.
  1. +66 −0 game.rkt
  2. +188 −0 gui.rkt
  3. +19 −12 init.rkt
View
66 game.rkt
@@ -0,0 +1,66 @@
+(load "gui.rkt")
+(load "init.rkt")
+;(require graphics/graphics) seems to work without it
+
+(define Game%
+ (class object%
+ (super-new)
+ (field (WIDTH 21)
+ (HEIGHT 21)
+ (*should-run* #f)
+ (mouse-x 0)
+ (mouse-y 0)
+ )
+
+ (define/public (get-width) WIDTH)
+ (define/public (get-height) HEIGHT)
+
+
+
+ (define (draw)
+ (clear)
+ (for-each (lambda (object) ;iterates through a list with all the objects and draws the objects images on the objects coordinates
+ (draw-pic (send object get-sprite)
+ (send object get-x)
+ (send object get-y)))
+ *object-list* )
+ ;(draw-pic *image* mouse-x mouse-y);(draw-pic character characterx charactery). Draws a picture where the mouse is.
+ (show)
+ )
+
+ (define (update)
+ (define templist (cons (car *object-list*) (cdr *object-list*)))
+ (for-each (lambda (object) (if (send object move) (display "removing snowball"))) templist)
+ (send *player* set-xy! mouse-x mouse-y)
+ (draw))
+
+ (define/public (update-mouse x y)
+ (set! mouse-x x)
+ (set! mouse-y y))
+
+
+ (define/public (pause-update)
+ (set! *should-run* #f)
+ )
+
+ (define/public (exit-game)
+ (pause-update)
+ (hide-gui *gui*))
+
+ (define/public (start-update)
+ (when (not *should-run*)
+ (set! *should-run* #t)
+ (new timer%
+ [notify-callback update]
+ [interval 20]
+ [just-once? #f])
+ (show-gui *gui*)))
+
+ (define/public (start-game)
+ (start-update)
+ )
+ )
+ )
+
+(define new-game (new Game%))
+(send new-game start-game)
View
188 gui.rkt
@@ -0,0 +1,188 @@
+;; ---------------------------------------------------------------------
+;; GUI
+;; ---------------------------------------------------------------------
+
+;; CONSTRUCTOR
+
+(define (make-gui frame canvas buffer dc)
+ (list frame canvas buffer dc))
+
+;; SELECTORS
+
+(define (get-frame gui)
+ (car gui))
+
+(define (get-canvas gui)
+ (cadr gui))
+
+(define (get-buffer gui)
+ (caddr gui))
+
+(define (get-dc gui)
+ (cadddr gui))
+
+(define (show-gui gui)
+ (send (get-frame gui) show #t))
+
+(define (hide-gui gui)
+ (send (get-frame gui) show #f))
+
+;; ---------------------------------------------------------------------
+;; Canvas
+;; ---------------------------------------------------------------------
+
+(define my-canvas%
+ (class canvas%
+ (override on-char)
+ (override on-event)
+ (init-field (key-callback #f))
+ (init-field (mouse-callback #f))
+ (define (on-char event)
+ (when key-callback
+ (key-callback event)))
+ (define (on-event event)
+ (when mouse-callback
+ (mouse-callback event)))
+ (super-instantiate ())))
+
+
+(define (mouse-fn mouse-event)
+ (let ((x (send mouse-event get-x))
+ (y (send mouse-event get-y))
+ (type (send mouse-event get-event-type)))
+ (case type
+ ((leave) null)
+ ((left-down)
+ (set! *object-list* (cons (send *player* throw) *object-list*))) ;if this goes slow, try change to mcons instead of cons
+ ;left mouse click causes player to throw, and adds the object snowball in the *object-list*
+ ((right-down)
+ (background 0 0 0))
+ ((motion)
+ (send new-game update-mouse x y))
+ )))
+
+
+
+
+
+(define (draw-canvas canvas dc)
+ (send dc draw-bitmap (get-buffer *gui*) 0 0))
+
+(define (redraw)
+ (send (get-canvas *gui*) on-paint))
+
+;; ---------------------------------------------------------------------
+;; Functions to draw
+;; ---------------------------------------------------------------------
+
+; A procedure that clears the GUI
+(define (clear)
+ (send *dc* clear))
+
+; A procedure that sets the background color of the GUI
+(define (background)
+ (send *dc* set-background (make-object color% (random 255) (random 255) (random 255))))
+
+(define (background r g b)
+ (send *dc* set-background (make-object color% r g b)))
+
+;; A procedures that draws an ellipse
+(define (draw-circle x y size-x size-y pen brush)
+ (send (get-dc *gui*) set-pen pen)
+ (send (get-dc *gui*) set-brush brush)
+ (send (get-dc *gui*) draw-ellipse x y size-x size-y))
+
+;; A procedures that draws a rectangle
+(define (draw-rectangle x y size-x size-y pen brush)
+ (send (get-dc *gui*) set-pen pen)
+ (send (get-dc *gui*) set-brush brush)
+ (send (get-dc *gui*) draw-rectangle x y size-x size-y))
+
+;; A procedures that draws a line
+(define (draw-line x y size-x size-y pen brush)
+ (send (get-dc *gui*) set-pen pen)
+ (send (get-dc *gui*) set-brush brush)
+ (send (get-dc *gui*) draw-line x y (+ x size-x) (+ y size-y)))
+
+;; A procedures that draws text
+(define (draw-text text x y pen brush)
+ (send (get-dc *gui*) set-pen pen)
+ (send (get-dc *gui*) set-brush brush)
+ (send (get-dc *gui*) draw-text text x y))
+
+;; A procedures that draws a picture from file
+(define (draw-pic file x y)
+ (send (get-dc *gui*) draw-bitmap file x y))
+
+; A procedure that shows the new GUI
+(define (show)
+ (redraw))
+
+;; The colors to draw with:
+(define *red-pen*
+ (send the-pen-list find-or-create-pen "red" 4 'solid))
+(define *green-pen*
+ (send the-pen-list find-or-create-pen "green" 2 'solid))
+(define *black-pen*
+ (send the-pen-list find-or-create-pen "black" 2 'solid))
+(define *blue-pen*
+ (send the-pen-list find-or-create-pen "blue" 2 'solid))
+(define *yellow-pen*
+ (send the-pen-list find-or-create-pen "yellow" 2 'solid))
+(define *white-pen*
+ (send the-pen-list find-or-create-pen "white" 2 'solid))
+
+(define *yellow-brush*
+ (send the-brush-list find-or-create-brush "yellow" 'solid))
+(define *red-brush*
+ (send the-brush-list find-or-create-brush "red" 'solid))
+(define *blue-brush*
+ (send the-brush-list find-or-create-brush "blue" 'solid))
+(define *green-brush*
+ (send the-brush-list find-or-create-brush "green" 'solid))
+(define *white-brush*
+ (send the-brush-list find-or-create-brush "white" 'solid))
+(define *black-brush*
+ (send the-brush-list find-or-create-brush "black" 'solid))
+
+
+
+;; --------------------------------------------------------------------
+;; The GUI and its components (buttons, menus etc)
+;; --------------------------------------------------------------------
+
+(define *frame* (make-object frame% "Ben is awesome"))
+
+
+(define *menu-bar*
+ (instantiate menu-bar%
+ (*frame*)))
+
+(define *menu*
+ (instantiate menu%
+ ("Menu" *menu-bar*)))
+
+(instantiate menu-item%
+ ("Quit" *menu* (lambda (a b) (hide-gui *gui*))))
+
+(define *canvas*
+ (instantiate my-canvas% ()
+ (parent *frame*)
+ (paint-callback draw-canvas)
+ (mouse-callback mouse-fn)
+ (min-height 672)
+ (min-width 672)
+ (stretchable-width #f)
+ (stretchable-height #f)))
+
+(define *buffer* (make-object bitmap% 832 832 #f))
+(define *dc* (make-object bitmap-dc% *buffer*))
+
+(define *gui*
+ (make-gui
+ *frame*
+ *canvas*
+ *buffer*
+ *dc*))
+
+
View
31 init.rkt
@@ -4,7 +4,7 @@
(class object%
(super-new)
- (field (x 0) (y 0) ;; position of object on screen
+ (init-field (x 0) (y 0) ;; position of object on screen
(sx 0) (sy 0) ;; space occupied by object on screen
(sprite "")) ;; path to image representing object on screen
@@ -17,20 +17,24 @@
(define/public (set-sy! new-sy) (set! sy new-sy))
(define/public (set-sprite! new-sprite) (set! sprite new-sprite))
- ;;--------------get-methods-------------------
+ ;--------------get-methods-------------------
(define/public (get-x) x)
(define/public (get-y) y)
(define/public (get-sx) sx)
(define/public (get-sy) sy)
- (define/public (get-sprite) sprite)))
+ (define/public (get-sprite) sprite)
+
+ ;--------------actions--------------------
+
+ (define/public (move) #f)))
(define player%
(class on-screen%
- (inherit set-xy! get-sx)
+ (inherit get-x get-y)
(super-new)
- (field (hp 2)) ; hitpoints
+ (init-field (hp 2)) ; hitpoints
;---------------set-methods-------------------
(define/public (set-hp! new-hp) (set! hp new-hp))
@@ -41,7 +45,10 @@
;---------------actions----------------------
(define/public (hit!) (if (> hp 0) (set! hp (- hp 1)) (display "Error already dead!")))
- (define/public (throw) (begin (define snowball (new snowball%)) (send snowball set-xy! 0 0) snowball))))
+ (define/public (throw) (new snowball%
+ [sprite (make-object bitmap% "snowball.jpg" 'unknown #f)]
+ [x (get-x)]
+ [y (get-y)]))))
@@ -49,7 +56,7 @@
(class on-screen%
(super-new)
(inherit set-x! get-x)
- (field (speed 0) (distance 5)) ; speed is negative for snowballs thrown left
+ (init-field (speed 1) (distance 5)) ; speed is negative for snowballs thrown left
;---------------set-methods-----------------
(define/public (set-throw_param! new-speed new-distance) (begin (set! speed new-speed)
@@ -63,7 +70,7 @@
(define/public (get-distance) distance)
;---------------actions---------------------
- (define/public (move) ; Returns #t when maximum distance is reached
+ (define/override (move) ; Returns #t when maximum distance is reached
(begin (set-x! (+ (get-x) speed))
(set! distance (- distance 1)) (= distance 0)))))
@@ -96,16 +103,16 @@
;----------instances-------------
(define *player*
- (new player%))
+ (new player% [sprite (make-object bitmap% "testbild.jpg" 'unknown #f)]))
+
+
;------------pictures-----------
-(define *image* (make-object bitmap% "testbild.jpg" 'unknown #f))
-(define *snowpic* (make-object bitmap% "snowball.jpg" 'unknown #f))
-(background 0 200 150)
+(define *object-list* (cons *player* null))
Please sign in to comment.
Something went wrong with that request. Please try again.