diff --git a/.dir-locals.el b/.dir-locals.el new file mode 100644 index 0000000..ff2dc18 --- /dev/null +++ b/.dir-locals.el @@ -0,0 +1,159 @@ +;; Per-directory local variables for GNU Emacs 23 and later. + +((nil + . ((fill-column . 78) + (tab-width . 8) + (sentence-end-double-space . t) + + (eval . (add-to-list 'completion-ignored-extensions ".go")) + + ;; Geiser + ;; This allows automatically setting the `geiser-guile-load-path' + ;; variable when using various Guix checkouts (e.g., via git worktrees). + (geiser-repl-per-project-p . t))) + + (c-mode . ((c-file-style . "gnu"))) + (scheme-mode + . + ((indent-tabs-mode . nil) + (eval . (put 'eval-when 'scheme-indent-function 1)) + (eval . (put 'call-with-prompt 'scheme-indent-function 1)) + (eval . (put 'test-assert 'scheme-indent-function 1)) + (eval . (put 'test-assertm 'scheme-indent-function 1)) + (eval . (put 'test-equalm 'scheme-indent-function 1)) + (eval . (put 'test-equal 'scheme-indent-function 1)) + (eval . (put 'test-eq 'scheme-indent-function 1)) + (eval . (put 'call-with-input-string 'scheme-indent-function 1)) + (eval . (put 'call-with-port 'scheme-indent-function 1)) + (eval . (put 'guard 'scheme-indent-function 1)) + (eval . (put 'lambda* 'scheme-indent-function 1)) + (eval . (put 'substitute* 'scheme-indent-function 1)) + (eval . (put 'match-record 'scheme-indent-function 3)) + (eval . (put 'match-record-lambda 'scheme-indent-function 2)) + + ;; TODO: Contribute these to Emacs' scheme-mode. + (eval . (put 'let-keywords 'scheme-indent-function 3)) + + ;; 'modify-inputs' and its keywords. + (eval . (put 'modify-inputs 'scheme-indent-function 1)) + (eval . (put 'replace 'scheme-indent-function 1)) + + ;; 'modify-phases' and its keywords. + (eval . (put 'modify-phases 'scheme-indent-function 1)) + (eval . (put 'replace 'scheme-indent-function 1)) + (eval . (put 'add-before 'scheme-indent-function 2)) + (eval . (put 'add-after 'scheme-indent-function 2)) + + (eval . (put 'modify-services 'scheme-indent-function 1)) + (eval . (put 'with-directory-excursion 'scheme-indent-function 1)) + (eval . (put 'with-file-lock 'scheme-indent-function 1)) + (eval . (put 'with-file-lock/no-wait 'scheme-indent-function 1)) + (eval . (put 'with-profile-lock 'scheme-indent-function 1)) + (eval . (put 'with-writable-file 'scheme-indent-function 2)) + + (eval . (put 'package 'scheme-indent-function 0)) + (eval . (put 'package/inherit 'scheme-indent-function 1)) + (eval . (put 'origin 'scheme-indent-function 0)) + (eval . (put 'build-system 'scheme-indent-function 0)) + (eval . (put 'bag 'scheme-indent-function 0)) + (eval . (put 'graft 'scheme-indent-function 0)) + (eval . (put 'operating-system 'scheme-indent-function 0)) + (eval . (put 'file-system 'scheme-indent-function 0)) + (eval . (put 'manifest-entry 'scheme-indent-function 0)) + (eval . (put 'manifest-pattern 'scheme-indent-function 0)) + (eval . (put 'substitute-keyword-arguments 'scheme-indent-function 1)) + (eval . (put 'with-store 'scheme-indent-function 1)) + (eval . (put 'with-external-store 'scheme-indent-function 1)) + (eval . (put 'with-error-handling 'scheme-indent-function 0)) + (eval . (put 'with-mutex 'scheme-indent-function 1)) + (eval . (put 'with-atomic-file-output 'scheme-indent-function 1)) + (eval . (put 'call-with-compressed-output-port 'scheme-indent-function 2)) + (eval . (put 'call-with-decompressed-port 'scheme-indent-function 2)) + (eval . (put 'call-with-gzip-input-port 'scheme-indent-function 1)) + (eval . (put 'call-with-gzip-output-port 'scheme-indent-function 1)) + (eval . (put 'call-with-lzip-input-port 'scheme-indent-function 1)) + (eval . (put 'call-with-lzip-output-port 'scheme-indent-function 1)) + (eval . (put 'signature-case 'scheme-indent-function 1)) + (eval . (put 'emacs-batch-eval 'scheme-indent-function 0)) + (eval . (put 'emacs-batch-edit-file 'scheme-indent-function 1)) + (eval . (put 'emacs-substitute-sexps 'scheme-indent-function 1)) + (eval . (put 'emacs-substitute-variables 'scheme-indent-function 1)) + (eval . (put 'with-derivation-narinfo 'scheme-indent-function 1)) + (eval . (put 'with-derivation-substitute 'scheme-indent-function 2)) + (eval . (put 'with-status-report 'scheme-indent-function 1)) + (eval . (put 'with-status-verbosity 'scheme-indent-function 1)) + (eval . (put 'with-build-handler 'scheme-indent-function 1)) + + (eval . (put 'mlambda 'scheme-indent-function 1)) + (eval . (put 'mlambdaq 'scheme-indent-function 1)) + (eval . (put 'syntax-parameterize 'scheme-indent-function 1)) + (eval . (put 'with-monad 'scheme-indent-function 1)) + (eval . (put 'mbegin 'scheme-indent-function 1)) + (eval . (put 'mwhen 'scheme-indent-function 1)) + (eval . (put 'munless 'scheme-indent-function 1)) + (eval . (put 'mlet* 'scheme-indent-function 2)) + (eval . (put 'mlet 'scheme-indent-function 2)) + (eval . (put 'mparameterize 'scheme-indent-function 2)) + (eval . (put 'run-with-store 'scheme-indent-function 1)) + (eval . (put 'run-with-state 'scheme-indent-function 1)) + (eval . (put 'wrap-program 'scheme-indent-function 1)) + (eval . (put 'wrap-script 'scheme-indent-function 1)) + (eval . (put 'with-imported-modules 'scheme-indent-function 1)) + (eval . (put 'with-extensions 'scheme-indent-function 1)) + (eval . (put 'with-parameters 'scheme-indent-function 1)) + (eval . (put 'let-system 'scheme-indent-function 1)) + (eval . (put 'with-build-variables 'scheme-indent-function 2)) + + (eval . (put 'with-database 'scheme-indent-function 2)) + (eval . (put 'call-with-database 'scheme-indent-function 1)) + (eval . (put 'call-with-transaction 'scheme-indent-function 1)) + (eval . (put 'call-with-retrying-transaction 'scheme-indent-function 1)) + + (eval . (put 'call-with-container 'scheme-indent-function 1)) + (eval . (put 'container-excursion 'scheme-indent-function 1)) + (eval . (put 'eventually 'scheme-indent-function 1)) + + (eval . (put 'call-with-progress-reporter 'scheme-indent-function 1)) + (eval . (put 'with-repository 'scheme-indent-function 2)) + (eval . (put 'with-temporary-git-repository 'scheme-indent-function 2)) + (eval . (put 'with-environment-variables 'scheme-indent-function 1)) + (eval . (put 'with-fresh-gnupg-setup 'scheme-indent-function 1)) + + (eval . (put 'with-paginated-output-port 'scheme-indent-function 1)) + + (eval . (put 'with-shepherd-action 'scheme-indent-function 3)) + + (eval . (put 'with-http-server 'scheme-indent-function 1)) + + ;; This notably allows '(' in Paredit to not insert a space when the + ;; preceding symbol is one of these. + (eval . (modify-syntax-entry ?~ "'")) + (eval . (modify-syntax-entry ?$ "'")) + (eval . (modify-syntax-entry ?+ "'")) + + ;; Emacs 28 changed the behavior of 'lisp-fill-paragraph', which causes the + ;; first line of package descriptions to extrude past 'fill-column', and + ;; somehow that is deemed more correct upstream (see: + ;; https://issues.guix.gnu.org/56197). + (eval . (progn + (require 'lisp-mode) + (defun emacs27-lisp-fill-paragraph (&optional justify) + (interactive "P") + (or (fill-comment-paragraph justify) + (let ((paragraph-start + (concat paragraph-start + "\\|\\s-*\\([(;\"]\\|\\s-:\\|`(\\|#'(\\)")) + (paragraph-separate + (concat paragraph-separate "\\|\\s-*\".*[,\\.]$")) + (fill-column (if (and (integerp emacs-lisp-docstring-fill-column) + (derived-mode-p 'emacs-lisp-mode)) + emacs-lisp-docstring-fill-column + fill-column))) + (fill-paragraph justify)) + ;; Never return nil. + t)) + (setq-local fill-paragraph-function #'emacs27-lisp-fill-paragraph))))) + + (emacs-lisp-mode . ((indent-tabs-mode . nil))) + (texinfo-mode . ((indent-tabs-mode . nil) + (fill-column . 72)))) diff --git a/game.scm b/game.scm index c822dfb..b14e780 100644 --- a/game.scm +++ b/game.scm @@ -36,118 +36,51 @@ (math vector)) ;; Data types -(define-record-type - (make-brick-type image points) - brick-type? - (image brick-type-image) - (points brick-type-points)) - -(define-record-type - (make-brick type hitbox) - brick? - (type brick-type) - (hitbox brick-hitbox) - (broken? brick-broken? set-brick-broken!)) - -(define-record-type - (make-ball velocity hitbox) - ball? - (velocity ball-velocity) - (hitbox ball-hitbox)) - -(define-record-type - (make-paddle velocity hitbox) - paddle? - (velocity paddle-velocity) - (hitbox paddle-hitbox)) (define-record-type - (make-level state bricks ball paddle score move-left? move-right? move-up? move-down?) + (make-level state player move-left? move-right? move-up? move-down?) level? (state level-state set-level-state!) ; play, win, lose - (bricks level-bricks) - (ball level-ball) - (paddle level-paddle) - (score level-score set-level-score!) + (player level-player) (move-left? level-move-left? set-level-move-left!) (move-right? level-move-right? set-level-move-right!) (move-up? level-move-up? set-level-move-up!) - (move-down? level-move-down? set-level-move-up!)) + (move-down? level-move-down? set-level-move-down!)) + +(define-record-type + (make-player velocity position hitbox weapon-primary) + entity? + (velocity player-velocity player-velocity-set!) + (position player-position player-position-set!) + (hitbox player-hitbox player-hitbox-set!) + (weapon-primary player-weapon-primary player-weapon-primary-set!)) ;; Assets -(define image:paddle (make-image "assets/images/paddle.png")) -(define image:ball (make-image "assets/images/ball.png")) -(define image:brick-red (make-image "assets/images/brick-red.png")) -(define image:brick-green (make-image "assets/images/brick-green.png")) -(define image:brick-blue (make-image "assets/images/brick-blue.png")) -(define audio:brick (make-audio "assets/sounds/brick.wav")) -(define audio:paddle (make-audio "assets/sounds/paddle.wav")) +(define image:player (make-image "assets/images/ball.png")) ;; Game data (define game-width 640.0) (define game-height 480.0) -(define brick-width 64.0) -(define brick-height 32.0) -(define ball-width 22.0) -(define ball-height 22.0) -(define paddle-width 104.0) -(define paddle-height 24.0) -(define paddle-speed 6.0) -(define brick:red (make-brick-type image:brick-red 10)) -(define brick:green (make-brick-type image:brick-green 20)) -(define brick:blue (make-brick-type image:brick-blue 30)) +(define player-width 22.0) +(define player-height 22.0) +(define player-speed 6.0) -(define (make-brick* type x y) - (make-brick type (make-rect x y brick-width brick-height))) - -(define (make-brick-grid types) - (let* ((h (vector-length types)) - (w (vector-length (vector-ref types 0))) - (offset-x (/ (- game-width (* w brick-width)) 2.0)) - (offset-y 48.0) - (bricks (make-vector (* w h)))) - (do ((y 0 (+ y 1))) - ((= y h)) - (let ((row (vector-ref types y))) - (do ((x 0 (+ x 1))) - ((= x w)) - (vector-set! bricks (+ (* y w) x) - (make-brick* (vector-ref row x) - (+ offset-x (* x brick-width)) - (+ offset-y (* y brick-height))))))) - bricks)) +(define (make-player* x y) + (make-player (vec2 0.0 0.0) + (vec2 x y) + (vec2 player-width player-height) + 'test-shot)) (define (make-level-1) (make-level 'play - (make-brick-grid - (vector - (vector brick:red brick:green brick:blue brick:red brick:green brick:blue brick:red brick:green) - (vector brick:green brick:blue brick:red brick:green brick:blue brick:red brick:green brick:blue) - (vector brick:blue brick:red brick:green brick:blue brick:red brick:green brick:blue brick:red) - (vector brick:red brick:green brick:blue brick:red brick:green brick:blue brick:red brick:green) - (vector brick:green brick:blue brick:red brick:green brick:blue brick:red brick:green brick:blue) - (vector brick:blue brick:red brick:green brick:blue brick:red brick:green brick:blue brick:red))) - (make-ball (vec2 1.0 3.0) - (make-rect (/ game-width 2.0) (/ game-height 2.0) - ball-width ball-height)) - (make-paddle (vec2 0.0 0.0) - (make-rect (- (/ game-width 2.0) - (/ paddle-width 2.0)) - (- game-height paddle-height 8.0) - paddle-width paddle-height)) - 0 #f #f #f #f)) + (make-player* 0 0) + #f #f #f #f)) ;; Game state (define *level* (make-level-1)) (define (level-clear? level) - (let ((bricks (level-bricks level))) - (let loop ((i 0)) - (if (< i (vector-length bricks)) - (if (brick-broken? (vector-ref bricks i)) - (loop (+ i 1)) - #f) - #t)))) + (#f)) (define (win! level) (set-level-state! level 'win)) @@ -155,101 +88,37 @@ (define (lose! level) (set-level-state! level 'lose)) -(define (update-paddle-velocity! level) - (let ((speed (* paddle-speed +(define (update-play-velocity! level) + (let ((speed (* player-speed (+ (if (level-move-left? level) -1.0 0.0) (if (level-move-right? level) 1.0 0.0) (if (level-move-up? level) 0.0 1.0) (if (level-move-down? level) 0.0 -1.0))))) - (set-vec2-x! (paddle-velocity (level-paddle level)) speed))) - -(define (speed-up-ball! ball) - (let* ((v (ball-velocity ball)) - (speed (+ (vec2-magnitude v) (* (random) 0.1))) - ;; Also change its angle slightly. Not the proper Breakout - ;; behavior but I don't want to write the code for that. :) - (dir (+ (atan (vec2-y v) (vec2-x v)) - (- (* (random) 0.5) 0.25)))) - (set-vec2-x! v (* (cos dir) speed)) - (set-vec2-y! v (* (sin dir) speed)))) - -(define (reflect-ball! ball x? y?) - (let ((v (ball-velocity ball))) - (when x? (set-vec2-x! v (- (vec2-x v)))) - (when y? (set-vec2-y! v (- (vec2-y v)))))) - -(define (collide-ball! ball hitbox) - (let ((b-hitbox (ball-hitbox ball))) - (and (rect-intersects? b-hitbox hitbox) - (let ((overlap (rect-clip b-hitbox hitbox))) - ;; Resolve collision by adjusting the ball's position the - ;; minimum amount along the X or Y axis. - (if (< (rect-width overlap) (rect-height overlap)) - (begin - (reflect-ball! ball #t #f) - (if (= (rect-x b-hitbox) (rect-x overlap)) - (set-rect-x! b-hitbox (+ (rect-x b-hitbox) (rect-width overlap))) - (set-rect-x! b-hitbox (- (rect-x b-hitbox) (rect-width overlap))))) - (begin - (reflect-ball! ball #f #t) - (if (= (rect-y b-hitbox) (rect-y overlap)) - (set-rect-y! b-hitbox (+ (rect-y b-hitbox) (rect-height overlap))) - (set-rect-y! b-hitbox (- (rect-y b-hitbox) (rect-height overlap)))))))))) + (set-vec2-x! (player-velocity (level-player level)) speed) + (set-vec2-y! (player-velocity (level-player level)) speed))) (define dt (/ 1000.0 60.0)) ; aim for updating at 60Hz (define (update) (match (level-state *level*) ('play - (let* ((bricks (level-bricks *level*)) - (ball (level-ball *level*)) - (b-velocity (ball-velocity ball)) - (b-hitbox (ball-hitbox ball)) - (paddle (level-paddle *level*)) - (p-velocity (paddle-velocity paddle)) - (p-hitbox (paddle-hitbox paddle)) - (score (level-score *level*))) - ;; Move ball and paddle - (set-rect-x! b-hitbox (+ (rect-x b-hitbox) (vec2-x b-velocity))) - (set-rect-y! b-hitbox (+ (rect-y b-hitbox) (vec2-y b-velocity))) - ;; We only move the paddle along the x-axis. - (set-rect-x! p-hitbox - (clamp (+ (rect-x p-hitbox) (vec2-x p-velocity)) - 0.0 - (- game-width paddle-width))) - ;; Collide ball against walls, bricks, and paddle. + (let* ((player (level-player *level*)) + (p-velocity (player-velocity player)) + (p-position (player-position player)) + (p-hitbox (player-hitbox player))) + ;; Move player + (set-vec2-x! p-position (+ (vec2-x p-position) (vec2-x p-velocity))) + (set-vec2-y! p-position (+ (vec2-y p-position) (vec2-y p-velocity))) + + ;; Keep player within the bounds of the game (cond - ((< (rect-x b-hitbox) 0.0) ; left wall - (set-rect-x! b-hitbox 0.0) - (reflect-ball! ball #t #f)) - ((> (+ (rect-x b-hitbox) (rect-width b-hitbox)) game-width) ; right wall - (set-rect-x! b-hitbox (- game-width (rect-width b-hitbox))) - (reflect-ball! ball #t #f)) - ((< (rect-y b-hitbox) 0.0) ; top wall - (set-rect-y! b-hitbox 0.0) - (reflect-ball! ball #f #t)) - ((> (+ (rect-y b-hitbox) (rect-height b-hitbox)) game-height) ; bottom wall - (lose! *level*)) - ((collide-ball! ball (paddle-hitbox paddle)) - (media-play audio:paddle) - (speed-up-ball! ball)) - (else - (let loop ((i 0) (hit? #f)) - (if (< i (vector-length bricks)) - (let ((brick (vector-ref bricks i))) - (if (and (not (brick-broken? brick)) - (collide-ball! ball (brick-hitbox brick))) - (begin - (media-play audio:brick) - (speed-up-ball! ball) - (set-brick-broken! brick #t) - (set-level-score! *level* - (+ (level-score *level*) - (brick-type-points (brick-type brick)))) - (loop (+ i 1) #t)) - (loop (+ i 1) hit?))) - ;; Maybe change to win state if all bricks are broken. - (when (and hit? (level-clear? *level*)) - (win! *level*)))))))) + ((< (vec2-x p-position) 0.0) ; left wall + (set-vec2-x! p-position 0.0)) + ((> (vec2-x p-position) game-width) ; right wall + (set-vec2-x! p-position game-width))) + ((< (vec2-y p-position) 0.0) ; top wall + (set-vec2-y! p-position 0.0)) + ((> (vec2-y p-position) game-height) ; bottom wall + (set-vec2-y! p-position game-height)))) (_ #t)) (timeout update-callback dt)) (define update-callback (procedure->external update)) @@ -264,53 +133,18 @@ str))))) (define (draw prev-time) - (let ((bricks (level-bricks *level*)) - (ball (level-ball *level*)) - (paddle (level-paddle *level*)) - (score (level-score *level*))) + (let ((player (level-player *level*))) ;; Draw background (set-fill-color! context "#140c1c") (fill-rect context 0.0 0.0 game-width game-height) - ;; Draw bricks - (do ((i 0 (+ i 1))) - ((= i (vector-length bricks))) - (let* ((brick (vector-ref bricks i)) - (type (brick-type brick)) - (hitbox (brick-hitbox brick))) - (unless (brick-broken? brick) - (draw-image context (brick-type-image type) - 0.0 0.0 - brick-width brick-height - (rect-x hitbox) (rect-y hitbox) - brick-width brick-height)))) - ;; Draw paddle - (let ((w 104.0) - (h 24.0) - (hitbox (paddle-hitbox paddle))) - (draw-image context image:paddle - 0.0 0.0 w h - (rect-x hitbox) (rect-y hitbox) w h)) - ;; Draw ball + + ;; Draw player (let ((w 22.0) (h 22.0) - (hitbox (ball-hitbox ball))) - (draw-image context image:ball + (position (player-position player))) + (draw-image context image:player 0.0 0.0 w h - (rect-x hitbox) (rect-y hitbox) w h)) - ;; Print score - (set-fill-color! context "#ffffff") - (set-font! context "bold 24px monospace") - (set-text-align! context "left") - (fill-text context "SCORE:" 16.0 36.0) - (fill-text context (number->string* score) 108.0 36.0) - (match (level-state *level*) - ('win - (set-text-align! context "center") - (fill-text context "YAY YOU DID IT!!!" (/ game-width 2.0) (/ game-height 2.0))) - ('lose - (set-text-align! context "center") - (fill-text context "OH NO, GAME OVER :(" (/ game-width 2.0) (/ game-height 2.0))) - (_ #t))) + (vec2-x position) (vec2-y position) w h))) (request-animation-frame draw-callback)) (define draw-callback (procedure->external draw)) @@ -327,17 +161,13 @@ ('play (cond ((string=? key key:left) - (set-level-move-left! *level* #t) - (update-paddle-velocity! *level*)) + (set-level-move-left! *level* #t)) ((string=? key key:right) - (set-level-move-right! *level* #t) - (update-paddle-velocity! *level*)) + (set-level-move-right! *level* #t)) ((string=? key key:up) - (set-level-move-up! *level* #t) - (update-paddle-velocity! *level*)) + (set-level-move-up! *level* #t)) ((string=? key key:down) - (set-level-move-down! *level* #t) - (update-paddle-velocity! *level*)))) + (set-level-move-down! *level* #t)))) ((or 'win 'lose) (when (string=? key key:confirm) (set! *level* (make-level-1))))))) @@ -348,17 +178,13 @@ ('play (cond ((string=? key key:left) - (set-level-move-left! *level* #f) - (update-paddle-velocity! *level*)) + (set-level-move-left! *level* #f)) ((string=? key key:right) - (set-level-move-right! *level* #f) - (update-paddle-velocity! *level*)) + (set-level-move-right! *level* #f)) ((string=? key key:up) - (set-level-move-up! *level* #f) - (update-paddle-velocity! *level*)) + (set-level-move-up! *level* #f)) ((string=? key key:down) - (set-level-move-down! *level* #f) - (update-paddle-velocity! *level*)))) + (set-level-move-down! *level* #f)))) (_ #t)))) ;; Canvas and event loop setup