Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- ; import relevant modules
- (use-modules ((sdl sdl) #:prefix SDL:)
- ((sdl gfx) #:prefix SDL:)
- (srfi srfi-1)
- (srfi srfi-2)
- (srfi srfi-9 gnu))
- (define (rgba r g b a)
- (logior (ash r 24) (logior (ash g 16) (logior (ash b 8) a))))
- (define (rgb r g b)
- (rgba r g b #xFF))
- ; constants
- (define (do-nothing state) state) ; rather than keep declaring lambdas, use this when the state is not to be altered
- (define bat-height 10)
- (define bat-width 96)
- (define ball-size 8)
- (define bat-vel 1)
- (define ball-vel 1)
- ; game state
- (define-immutable-record-type <settings>
- (make-settings bat-y screen-width screen-height)
- settings?
- (bat-y settings-bat-y)
- (screen-width settings-screen-width)
- (screen-height settings-screen-height))
- (define-immutable-record-type <gamestate>
- (make-gamestate ball-x ball-y ball-vx ball-vy bat-x bat-vx inplay)
- gamestate?
- (ball-x gamestate-ball-x set-gamestate-ball-x)
- (ball-y gamestate-ball-y set-gamestate-ball-y)
- (ball-vx gamestate-ball-vx set-gamestate-ball-vx)
- (ball-vy gamestate-ball-vy set-gamestate-ball-vy)
- (bat-x gamestate-bat-x set-gamestate-bat-x)
- (bat-vx gamestate-bat-vx set-gamestate-bat-vx)
- (inplay gamestate-inplay set-gamestate-inplay))
- ; handle quit event
- (define (handle-quit)
- (SDL:quit)
- (quit)
- )
- (define (handle-keydown key)
- (display "keydown: ")
- (display key)
- (display "\n")
- (case key
- ((escape) (handle-quit))
- ((left) (lambda (state) (set-gamestate-bat-vx state (- (gamestate-bat-vx state) bat-vel))))
- ((right) (lambda (state) (set-gamestate-bat-vx state (+ (gamestate-bat-vx state) bat-vel))))
- (else do-nothing))
- )
- (define (handle-keyup key)
- (display "keyup: ")
- (display key)
- (display "\n")
- (case key
- ((escape) (handle-quit))
- ((left) (lambda (state) (set-gamestate-bat-vx state (+ (gamestate-bat-vx state) bat-vel))))
- ((right) (lambda (state) (set-gamestate-bat-vx state (- (gamestate-bat-vx state) bat-vel))))
- (else do-nothing))
- )
- ; event handler
- (define (handle-event)
- (let ((e (SDL:make-event)))
- (if (SDL:poll-event e)
- ; event happened
- (case (SDL:event:type e)
- ((quit) (handle-quit))
- ((key-down) (handle-keydown (SDL:event:key:keysym:sym e)))
- ((key-up) (handle-keyup (SDL:event:key:keysym:sym e)))
- (else do-nothing)
- )
- ; no event
- do-nothing)
- ))
- ; drawing
- (define (render settings state)
- (let* ((screen (SDL:display-format (SDL:make-surface (settings-screen-width settings) (settings-screen-height settings))))
- (format (SDL:surface-get-format screen)))
- ; draw background
- (SDL:draw-rectangle screen 0 0 (settings-screen-width settings) (settings-screen-height settings) (rgb 0 0 0) #t)
- ; draw bat
- (let ((batx (gamestate-bat-x state) )
- (baty (settings-bat-y settings)))
- (SDL:draw-rectangle screen batx baty (+ batx bat-width) (+ baty bat-height) (rgb 255 255 255) #t))
- ; draw ball
- (let ((ballx (gamestate-ball-x state))
- (bally (gamestate-ball-y state)))
- (SDL:draw-rectangle screen ballx bally (+ ballx ball-size) (+ bally ball-size) (rgb 255 255 255) #t))
- ; copy this surface to the screen
- (SDL:blit-surface screen)
- (SDL:flip)
- )
- )
- ; update state
- (define (update-state settings state)
- (let* ((ball-x (gamestate-ball-x state))
- (ball-y (gamestate-ball-y state))
- (ball-vx (gamestate-ball-vx state))
- (ball-vy (gamestate-ball-vy state))
- (bat-x (gamestate-bat-x state))
- (bat-vx (gamestate-bat-vx state))
- (moved-ball-x (+ ball-x ball-vx))
- (moved-ball-y (+ ball-y ball-vy))
- (moved-bat-x (+ bat-x bat-vx))
- (final-ball-vx (if (or (< moved-ball-x 0) (> (+ moved-ball-x ball-size) (settings-screen-width settings))) (* -1 ball-vx) ball-vx))
- (final-ball-vy (if (or (< moved-ball-y 0) (and (> (+ moved-ball-y ball-size) (settings-bat-y settings)) (and (> (+ ball-x ball-size) bat-x) (< ball-x (+ bat-x bat-width))))) (* -1 ball-vy) ball-vy))
- (final-bat-x (if (or (< moved-bat-x 0) (> (+ moved-bat-x bat-width) (settings-screen-width settings))) bat-x moved-bat-x))
- (final-ball-x (if (or (< moved-ball-x 0) (> (+ moved-ball-x ball-size) (settings-screen-width settings))) ball-x moved-ball-x))
- (final-ball-y (if (or (< moved-ball-y 0) (and (> (+ moved-ball-y ball-size) (settings-bat-y settings)) (and (> (+ ball-x ball-size) bat-x) (< ball-x (+ bat-x bat-width))))) ball-y moved-ball-y))
- )
- (make-gamestate final-ball-x
- final-ball-y
- final-ball-vx
- final-ball-vy
- final-bat-x
- (gamestate-bat-vx state)
- (gamestate-inplay state))
- ))
- ; main game loop
- (define (main-loop settings state)
- ; draw to the screen
- (render settings state)
- ; update state based on events and pass new state back into the next iteration of the loop
- (main-loop settings (update-state settings ((handle-event) state)))
- )
- ; prepare sdl
- (define (init width height bpp)
- ; set up video
- (SDL:init 'video)
- (SDL:set-video-mode width height bpp 'hw-surface)
- ; jump into game
- (let* ((bat-y (- height (/ height 5)))
- (ball-x (- (/ width 2) (/ ball-size 2)))
- (bat-x (- (/ width 2) (/ bat-width 2)))
- (ball-y (- bat-y ball-size)))
- (main-loop
- (make-settings bat-y width height)
- (make-gamestate ball-x ball-y -1 -1 bat-x 0 #f)))
- )
- ; entry point to program
- (init 640 480 32)
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement