SHARE
TWEET

Untitled

a guest Dec 14th, 2013 214 Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. ; import relevant modules
  2. (use-modules  ((sdl sdl) #:prefix SDL:)
  3.               ((sdl gfx) #:prefix SDL:)
  4.               (srfi srfi-1)
  5.               (srfi srfi-2)
  6.               (srfi srfi-9 gnu))
  7.  
  8. (define (rgba r g b a)
  9.   (logior (ash r 24) (logior (ash g 16) (logior (ash b 8) a))))
  10.  
  11. (define (rgb r g b)
  12.   (rgba r g b #xFF))
  13.  
  14. ; constants
  15. (define (do-nothing state) state) ; rather than keep declaring lambdas, use this when the state is not to be altered
  16. (define bat-height 10)
  17. (define bat-width 96)
  18. (define ball-size 8)
  19. (define bat-vel 1)
  20. (define ball-vel 1)
  21.  
  22. ; game state
  23. (define-immutable-record-type <settings>
  24.   (make-settings bat-y screen-width screen-height)
  25.   settings?
  26.   (bat-y          settings-bat-y)
  27.   (screen-width    settings-screen-width)
  28.   (screen-height  settings-screen-height))
  29.  
  30. (define-immutable-record-type <gamestate>
  31.   (make-gamestate ball-x ball-y ball-vx ball-vy bat-x bat-vx inplay)
  32.   gamestate?
  33.   (ball-x    gamestate-ball-x  set-gamestate-ball-x)
  34.   (ball-y    gamestate-ball-y  set-gamestate-ball-y)
  35.   (ball-vx  gamestate-ball-vx  set-gamestate-ball-vx)
  36.   (ball-vy  gamestate-ball-vy  set-gamestate-ball-vy)
  37.   (bat-x    gamestate-bat-x    set-gamestate-bat-x)
  38.   (bat-vx    gamestate-bat-vx  set-gamestate-bat-vx)
  39.   (inplay    gamestate-inplay  set-gamestate-inplay))
  40.    
  41. ; handle quit event
  42. (define (handle-quit)
  43.   (SDL:quit)
  44.   (quit)
  45.   )
  46.  
  47. (define (handle-keydown key)
  48.   (display "keydown: ")
  49.   (display key)
  50.   (display "\n")
  51.   (case key
  52.     ((escape) (handle-quit))
  53.     ((left) (lambda (state) (set-gamestate-bat-vx state (- (gamestate-bat-vx state) bat-vel))))
  54.     ((right) (lambda (state) (set-gamestate-bat-vx state (+ (gamestate-bat-vx state) bat-vel))))
  55.     (else do-nothing))
  56.   )
  57.  
  58. (define (handle-keyup key)
  59.   (display "keyup: ")
  60.   (display key)
  61.   (display "\n")
  62.   (case key
  63.     ((escape) (handle-quit))
  64.     ((left) (lambda (state) (set-gamestate-bat-vx state (+ (gamestate-bat-vx state) bat-vel))))
  65.     ((right) (lambda (state) (set-gamestate-bat-vx state (- (gamestate-bat-vx state) bat-vel))))
  66.     (else do-nothing))
  67.   )
  68.  
  69. ; event handler
  70. (define (handle-event)
  71.   (let ((e (SDL:make-event)))
  72.     (if (SDL:poll-event e)
  73.       ; event happened
  74.       (case (SDL:event:type e)
  75.         ((quit) (handle-quit))
  76.         ((key-down) (handle-keydown (SDL:event:key:keysym:sym e)))
  77.         ((key-up) (handle-keyup (SDL:event:key:keysym:sym e)))
  78.         (else do-nothing)
  79.         )
  80.       ; no event
  81.       do-nothing)
  82.       ))
  83.      
  84. ; drawing
  85. (define (render settings state)
  86.   (let* ((screen (SDL:display-format (SDL:make-surface (settings-screen-width settings) (settings-screen-height settings))))
  87.         (format (SDL:surface-get-format screen)))
  88.     ; draw background
  89.     (SDL:draw-rectangle screen 0 0 (settings-screen-width settings) (settings-screen-height settings) (rgb 0 0 0) #t)
  90.    
  91.     ; draw bat
  92.     (let ((batx (gamestate-bat-x state) )
  93.           (baty (settings-bat-y settings)))
  94.       (SDL:draw-rectangle screen batx baty (+ batx bat-width) (+ baty bat-height) (rgb 255 255 255) #t))
  95.      
  96.     ; draw ball
  97.     (let ((ballx (gamestate-ball-x state))
  98.           (bally (gamestate-ball-y state)))
  99.       (SDL:draw-rectangle screen ballx bally (+ ballx ball-size) (+ bally ball-size) (rgb 255 255 255) #t))
  100.  
  101.     ; copy this surface to the screen
  102.     (SDL:blit-surface screen)
  103.     (SDL:flip)
  104.     )
  105.   )
  106.  
  107. ; update state
  108. (define (update-state settings state)
  109.   (let* ((ball-x (gamestate-ball-x state))
  110.          (ball-y (gamestate-ball-y state))
  111.          (ball-vx (gamestate-ball-vx state))
  112.          (ball-vy (gamestate-ball-vy state))
  113.          (bat-x (gamestate-bat-x state))
  114.          (bat-vx (gamestate-bat-vx state))
  115.          (moved-ball-x (+ ball-x ball-vx))
  116.          (moved-ball-y (+ ball-y ball-vy))
  117.          (moved-bat-x (+ bat-x bat-vx))
  118.          (final-ball-vx (if (or (< moved-ball-x 0) (> (+ moved-ball-x ball-size) (settings-screen-width settings))) (* -1 ball-vx) ball-vx))
  119.          (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))
  120.          (final-bat-x (if (or (< moved-bat-x 0) (> (+ moved-bat-x bat-width) (settings-screen-width settings))) bat-x moved-bat-x))
  121.          (final-ball-x (if (or (< moved-ball-x 0) (> (+ moved-ball-x ball-size) (settings-screen-width settings))) ball-x moved-ball-x))
  122.          (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))
  123.          )
  124.       (make-gamestate final-ball-x
  125.                       final-ball-y
  126.                       final-ball-vx
  127.                       final-ball-vy
  128.                       final-bat-x
  129.                       (gamestate-bat-vx state)
  130.                       (gamestate-inplay state))
  131.     ))
  132.  
  133. ; main game loop
  134. (define (main-loop settings state)
  135.   ; draw to the screen
  136.   (render settings state)
  137.   ; update state based on events and pass new state back into the next iteration of the loop
  138.   (main-loop settings (update-state settings ((handle-event) state)))
  139.   )
  140.  
  141. ; prepare sdl
  142. (define (init width height bpp)
  143.   ; set up video
  144.   (SDL:init 'video)
  145.   (SDL:set-video-mode width height bpp 'hw-surface)
  146.  
  147.   ; jump into game
  148.   (let* ((bat-y (- height (/ height 5)))
  149.          (ball-x (- (/ width 2) (/ ball-size 2)))
  150.          (bat-x (- (/ width 2) (/ bat-width 2)))
  151.          (ball-y (- bat-y ball-size)))
  152.   (main-loop
  153.     (make-settings bat-y width height)
  154.     (make-gamestate ball-x ball-y -1 -1 bat-x 0 #f)))
  155.   )
  156.  
  157. ; entry point to program
  158. (init 640 480 32)
RAW Paste Data
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy. OK, I Understand
Not a member of Pastebin yet?
Sign Up, it unlocks many cool features!
 
Top