diff options
Diffstat (limited to 'scripts')
| -rw-r--r-- | scripts/main.el | 210 | ||||
| -rw-r--r-- | scripts/main.scm | 299 | ||||
| -rw-r--r-- | scripts/prompt.scm | 45 | ||||
| -rw-r--r-- | scripts/stage.scm | 0 | ||||
| -rw-r--r-- | scripts/structs.scm | 80 | ||||
| -rw-r--r-- | scripts/utils.scm | 8 |
6 files changed, 209 insertions, 433 deletions
diff --git a/scripts/main.el b/scripts/main.el index 2c6c54d..92a50e1 100644 --- a/scripts/main.el +++ b/scripts/main.el @@ -1,3 +1,211 @@ +(defvar key-left 65361) ;; macroquad input code +(defvar key-up 65362) +(defvar key-right 65363) +(defvar key-down 65364) + +(defvar gameover ()) +(defvar tile-size (list 18.0 24.0)) +(defvar subtile-width 5.0) +(defvar subtile-height 7.0) + +(defvar player-direction ()) +(defvar player-body (list (list 3 2))) +(defvar frame-timer-duration 0.3) +(defvar frame-timer 0.0) +(defvar fruit-tile (list 4 5)) + + +(defun is-tile-equal? (pos1 pos2) + (and (== (car pos1) (car pos2)) (== (cadr pos1) (cadr pos2))) + ) + +(defun sum-pos (pos1 pos2) + (list (+ (car pos1) (car pos2)) (+ (cadr pos1) (cadr pos2))) + ) + +(defun tile-to-pos (tile) + (list (* (car tile) (car tile-size)) (* (cadr tile) (cadr tile-size))) + ) + +(defun draw-subtile (tile subtile) + (defvar offset (tile-to-pos tile)) + (mq-draw-rectangle (+ (car offset) (+ (* subtile-width (car subtile)) (car subtile))) (+ (cadr offset) (+ (* subtile-height (cadr subtile)) (cadr subtile))) subtile-width subtile-height) + ) + +(defun draw-fruit (tile) + (draw-subtile tile (list 1 0)) + (draw-subtile tile (list 2 1)) + (draw-subtile tile (list 1 2)) + (draw-subtile tile (list 0 1)) + ) + +(defun draw-horizontal-line (tile) + (draw-subtile tile (list 0 1)) + (draw-subtile tile (list 1 1)) + (draw-subtile tile (list 2 1)) + ) + +(defun draw-vertical-line (tile) + (draw-subtile tile (list 1 0)) + (draw-subtile tile (list 1 1)) + (draw-subtile tile (list 1 2)) + ) + +(defun draw-corner-tl (tile) + (draw-subtile tile (list 1 1)) + (draw-subtile tile (list 2 1)) + (draw-subtile tile (list 1 2)) + ) + +(defun draw-corner-tr (tile) + (draw-subtile tile (list 1 1)) + (draw-subtile tile (list 0 1)) + (draw-subtile tile (list 1 2)) + ) + +(defun draw-corner-bl (tile) + (draw-subtile tile (list 1 1)) + (draw-subtile tile (list 1 0)) + (draw-subtile tile (list 2 1)) + ) + +(defun draw-corner-br (tile) + (draw-subtile tile (list 1 1)) + (draw-subtile tile (list 1 0)) + (draw-subtile tile (list 0 1)) + ) + +(defun draw-snake-tile (tile) + (defvar offset (tile-to-pos tile)) + (mq-draw-rectangle (car offset) (cadr offset) (car tile-size) (cadr tile-size) 0.4) + (draw-subtile tile (list 0 0)) + (draw-subtile tile (list 1 0)) + (draw-subtile tile (list 2 0)) + (draw-subtile tile (list 0 1)) + (draw-subtile tile (list 1 1)) + (draw-subtile tile (list 2 1)) + (draw-subtile tile (list 0 2)) + (draw-subtile tile (list 1 2)) + (draw-subtile tile (list 2 2)) + ) + +(defun process-input () + (if (mq-is-key-pressed key-left) + (setq player-direction key-left)) + (if (mq-is-key-pressed key-right) + (setq player-direction key-right)) + (if (mq-is-key-pressed key-up) + (setq player-direction key-up)) + (if (mq-is-key-pressed key-down) + (setq player-direction key-down)) + ) + +(defun move-player-body (dir) + (setq player-body (move-player-body-aux player-body (sum-pos (car player-body) dir))) + ) + +(defun move-player-body-aux (body pos) + (if (not (null (cdr body))) + (cons pos (move-player-body-aux (cdr body) (car body))) + (cons pos ())) + ) + +(defun push-new-tile () + (setq player-body (push-new-tile-aux player-body)) + ) + +(defun push-new-tile-aux (body) + (if (null (cdr body)) + (list (car body) (car body)) + (cons (car body) (push-new-tile-aux (cdr body))) + )) + +(defun check-collision-self () + (if (null (cdr player-body)) + () + (check-collision-self-aux (cdr player-body) (car player-body))) + ) + +(defun check-collision-self-aux (body pos) + (if (is-tile-equal? (car body) pos) + 1 + (if (null (cdr body)) + () + (check-collision-self-aux (cdr body) pos)) + ) + ) + +(defun process-frame () + ;; Set frame timer to 0 (game is running at 60 FPS) + (setq frame-timer 0.0) + + ;; Move player + (if (== player-direction key-left) + (move-player-body (list -1 0)) + ) + + (if (== player-direction key-up) + (move-player-body (list 0 -1)) + ) + + (if (== player-direction key-right) + (move-player-body (list 1 0)) + ) + + (if (== player-direction key-down) + (move-player-body (list 0 1)) + ) + + ;; Check collision with self + (if (check-collision-self) + (setq gameover 1)) + + + ;; Check collision border + (if (or (<= (car (car player-body)) 2) + (>= (car (car player-body)) 31) + (<= (cadr (car player-body)) 1) + (>= (cadr (car player-body)) 22)) + (setq gameover 1)) + + ;; Check collision with fruit + (if (is-tile-equal? (car player-body) fruit-tile) + (begin + (push-new-tile) + (setq fruit-tile (list (randi-range 3 30) (randi-range 2 21))))) + ) + + +(defun update (dt) + (process-input) + + (setq frame-timer (+ frame-timer dt)) + (if (and (not gameover) (> frame-timer frame-timer-duration)) + (process-frame)) + + + ) + + (defun draw () - (rq-draw-circle 50.0 50.0 40.0) + (mapcar (lambda (tile) + (draw-snake-tile tile)) + player-body) + + (mapcar (lambda (i) + (draw-vertical-line (list 2 i)) + (draw-vertical-line (list 31 i))) + (range 2 22)) + + (mapcar (lambda (i) + (draw-horizontal-line (list i 1)) + (draw-horizontal-line (list i 22))) + (range 3 31)) + + (draw-corner-tl (list 2 1)) + (draw-corner-tr (list 31 1)) + (draw-corner-bl (list 2 22)) + (draw-corner-br (list 31 22)) + + (draw-fruit fruit-tile) ) diff --git a/scripts/main.scm b/scripts/main.scm deleted file mode 100644 index 9db17fc..0000000 --- a/scripts/main.scm +++ /dev/null @@ -1,299 +0,0 @@ -(load "./scripts/structs.scm") -(load "./scripts/utils.scm") -(load "./scripts/prompt.scm") -(load "./scripts/gol.scm") - -(define current-stage-number 0) -(define current-generation 0) -(define current-pressed-key #f) -(define starting-cells (list)) -(define trigger-level-reload #t) -(define overlay-fade-time 0.0) -(define is-advancing #f) - - -(define stages (list (list '(1 . 0) - '(1 . 1) - '(0 . 0) - '(0 . 1)) - (list '(0 . -1) - '(1 . 0) - '(0 . 1) - '(-1 . 0)) - (list '(0 . 0) - '(0 . 1) - '(0 . 2)) - (list '(0 . 0) - '(-1 . 0) - '(0 . -1)) - (list '(1 . 0) - '(0 . 1)) - (list '(2 . 0) - '(1 . 0) - '(1 . 1) - '(0 . 1) - '(0 . 2)) - (list '(-1 . -1) - '(0 . -1) - '(1 . 0) - '(0 . 1) - '(-1 . 1) - '(-2 . 0)) - (list '(-1 . -1) - '(0 . -1) - '(1 . -1) - '(-1 . 0) - '(1 . 0) - '(-1 . 1) - '(0 . 1) - '(1 . 1)) - (list '(0 . -1) - '(0 . 0) - '(0 . 1) - '(1 . -1) - '(1 . 0) - '(1 . 1) - '(2 . 0)) - )) - -(define (update-generation) - (clear-cells) - (set-cells-array starting-cells) - - (let loop ((times 0)) - (if (< times current-generation) - (begin (run-step) - (loop (+ times 1))) - ) - ) - ) - -(define (is-solution? l1) - (define trigger #t) - (for-each (lambda (c) - (if (not (hash-table-ref current-cells c)) - (begin (set! trigger #f))) - ) - (stages current-stage-number)) - (and trigger (eq? (length (stages current-stage-number)) (length (hash-table-keys current-cells)))) - ) - -(define (update-game) - - (set! current-pressed-key (rl-get-key-pressed)) - - (prompt-update) - - (if trigger-level-reload - (begin (set! starting-cells (list)) - (clear-cells) - (set-cells-array starting-cells) - (set! trigger-level-reload #f))) - - (cond ((and (not prompt-active) (not is-advancing)) - (if (eq? current-pressed-key KEY_LEFT) - (cond ((> current-generation 0) - (set! current-generation (- current-generation 1)) - (update-generation))) - ) - - (if (eq? current-pressed-key KEY_RIGHT) - (cond ((< current-generation 1) - (set! current-generation (+ current-generation 1)) - (update-generation))) - ) - - )) - - (if (and (eq? current-generation 1) (not is-advancing)) - (if (is-solution? (stages current-stage-number)) - (begin (set! is-advancing #t) - (set! overlay-fade-time 0.0)) - ) - ) - - (if (and (rl-is-mouse-button-pressed) (eq? current-generation 0)) - (let ((mouse-pos (rl-get-mouse-position))) - (define tile-x (floor ( / (- (mouse-pos 0) 275) 50))) - (define tile-y (floor ( / (- (mouse-pos 1) 200) 50))) - (if (and (>= tile-x -1) - (<= tile-x 1) - (>= tile-y -1) - (<= tile-y 1)) - (begin (toggle-cell `(,tile-x . ,tile-y)) - (set! starting-cells (get-cells-list)))) - )) - - (if is-advancing - (set! overlay-fade-time (+ overlay-fade-time (rl-get-frame-time))) - (set! overlay-fade-time (- overlay-fade-time (rl-get-frame-time))) - ) - - (if (> overlay-fade-time 1.0) - (begin (set! is-advancing #f) - (clear-cells) - (set! starting-cells (list)) - (set! current-generation 0) - (set! current-stage-number (+ current-stage-number 1)) - ) - ) - ) - -(define (update-end) - (if is-advancing - (set! overlay-fade-time (+ overlay-fade-time (rl-get-frame-time))) - (set! overlay-fade-time (- overlay-fade-time (rl-get-frame-time))) - ) - ) - -(define (update) - (if (>= current-stage-number (length stages)) - (update-end) - (update-game) - ) - ) - -(define (draw-game) - (rl-draw-rectangle 0 0 600 450 (make-color 255 255 255 255)) - - (prompt-draw) - - (rl-draw-text (string-append "Level " (number->string current-stage-number)) 75 15 20 (make-color 0 0 0 255)) - - (draw-cells) - - (draw-grid) - - (draw-generation) - - (define lerped-alpha (* 255.0 overlay-fade-time) ) - (if (< lerped-alpha 0.0) - (set! lerped-alpha 0.0)) - - (rl-draw-rectangle 0 0 600 450 (make-color 255 255 255 (floor lerped-alpha))) - ) - -(define (draw-end) - (rl-draw-rectangle 0 0 600 450 (make-color 255 255 255 255)) - - (rl-draw-text "The end! Thank you for playing :)" 38 200 30 (make-color 0 0 0 255)) - - (rl-draw-text "Made with Raylib + S7 Scheme" 146 340 20 (make-color 0 0 0 255)) - - (define lerped-alpha (* 255.0 overlay-fade-time) ) - (if (< lerped-alpha 0.0) - (set! lerped-alpha 0.0)) - - (rl-draw-rectangle 0 0 600 450 (make-color 255 255 255 (floor lerped-alpha))) - ) - -(define (draw-generation) - - (let loop ((times 0)) - (if (< times 2) - (begin - (rl-draw-rectangle (+ 75 (* times 40)) - 410 - 30 - 30 - (make-color 190 190 190 255)) - (if (eq? times current-generation) - (rl-draw-rectangle (+ 80 (* times 40)) - 415 - 20 - 20 - (make-color 0 0 0 255))) - - (loop (+ times 1)) - ))) - - ) - -(define (draw) - (if (>= current-stage-number (length stages)) - (draw-end) - (draw-game) - ) - ) - - -(define (draw-grid) - (define cell-width 50) - (define cell-height 50) - - (let loop ((times 10)) - (if (> times 0) - (begin (rl-draw-line (+ (* times cell-width) (* cell-width 0.5)) - 50 - (+ (* times cell-width) (* cell-width 0.5)) - 400 - (make-color 200 200 200 255)) - (loop (- times 1))) - ) - ) - - (let loop ((times 8)) - (if (> times 0) - (begin (rl-draw-line 75 - (* times cell-height) - 525 - (* times cell-height) - (make-color 200 200 200 255)) - (loop (- times 1))) - ) - ) - - (let loop ((times 4)) - (if (> times 0) - (begin (rl-draw-line (+ (* times cell-width) 175) - 150 - (+ (* times cell-width) 175) - 300 - (make-color 0 0 0 255)) - (loop (- times 1))) - ) - ) - - (let loop ((times 4)) - (if (> times 0) - (begin (rl-draw-line 225 - (+ (* times cell-height) 100) - 375 - (+ (* times cell-height) 100) - (make-color 0 0 0 255)) - (loop (- times 1))) - ) - ) - ) - -(define (draw-cells) - (define cell-width 50) - (define cell-height 50) - (define cell-color (if (eq? current-generation 0) - (make-color 190 100 255 255) - (make-color 255 190 100 255))) - - - (for-each (lambda (cell) - (rl-draw-rectangle - (+ (* (car cell) cell-width) (- 300 (* cell-width 0.5)) ) - (+ (* (cdr cell) cell-height) (- 225 (* cell-height 0.5)) ) - cell-width - cell-height - cell-color) - - ) (hash-table-keys current-cells)) - - - (for-each (lambda (cell) - (rl-draw-rectangle - (+ (* (car cell) 50) 290 ) - (+ (* (cdr cell) 50) 215 ) - 20 - 20 - (make-color 255 190 100 255)) - - ) (stages current-stage-number)) - - - ) diff --git a/scripts/prompt.scm b/scripts/prompt.scm deleted file mode 100644 index e78e5b3..0000000 --- a/scripts/prompt.scm +++ /dev/null @@ -1,45 +0,0 @@ -(define prompt-active #f) -(define prompt-box (make-rect 0 0 800 20)) -(define prompt-text "") - -(define (prompt-update) - (if (eq? current-pressed-key KEY_F1) - (set! prompt-active (not prompt-active)) - ) - - (if prompt-active - (begin - (let ((key (rl-get-char-pressed))) - (cond ((and (>= key 32) (<= key 125)) - (set! prompt-text - (string-append prompt-text (string (integer->char key))))) - )) - - (if (rl-is-key-down KEY_ENTER) - (begin - (eval-string prompt-text) - (set! prompt-text "") - )) - - (if (eq? current-pressed-key KEY_BACKSPACE) - (let ((n (string-length prompt-text))) - (cond ((>= n 1) - (set! prompt-text (substring prompt-text 0 (- n 1)))) - ))) - - )) - - ) - -(define (prompt-draw) - (if prompt-active - (begin - (rl-draw-rectangle - (rect-x prompt-box) - (rect-y prompt-box) - (rect-width prompt-box) - (rect-height prompt-box) - (make-color 190 100 255 255)) - (rl-draw-text prompt-text 0 0 20 (make-color 0 0 0 255)) - )) - ) diff --git a/scripts/stage.scm b/scripts/stage.scm deleted file mode 100644 index e69de29..0000000 --- a/scripts/stage.scm +++ /dev/null diff --git a/scripts/structs.scm b/scripts/structs.scm deleted file mode 100644 index c3fa6ea..0000000 --- a/scripts/structs.scm +++ /dev/null @@ -1,80 +0,0 @@ -;; ============================================================ -;; define defstruct macro -(define-macro (defstruct struct-name . fields) - (let* ((name (if (list? struct-name) (car struct-name) struct-name)) - (sname (if (string? name) name (symbol->string name))) - - (fsname (if (list? struct-name) - (let ((cname (assoc :conc-name (cdr struct-name)))) - (if cname - (symbol->string (cadr cname)) - sname)) - sname)) - - (make-name (if (list? struct-name) - (let ((cname (assoc :constructor (cdr struct-name)))) - (if cname - (cadr cname) - (symbol "make-" sname))) - (symbol "make-" sname))) - - (copy-name (if (list? struct-name) - (let ((cname (assoc :copier (cdr struct-name)))) - (if cname - (cadr cname) - (symbol "copy-" sname))) - (symbol "copy-" sname))) - - (field-names (map (lambda (n) - (symbol->string (if (list? n) (car n) n))) - fields)) - - (field-types (map (lambda (field) - (if (list? field) - (apply (lambda* (val type read-only) type) (cdr field)) - #f)) - fields)) - - (field-read-onlys (map (lambda (field) - (if (list? field) - (apply (lambda* (val type read-only) read-only) (cdr field)) - #f)) - fields))) - - `(begin - (define ,(symbol sname "?") - (lambda (obj) - (and (vector? obj) - (eq? (obj 0) ',(string->symbol sname))))) - - (define* (,make-name - ,@(map (lambda (n) - (if (and (list? n) - (>= (length n) 2)) - (list (car n) (cadr n)) - (list n #f))) - fields)) - (vector ',(string->symbol sname) ,@(map string->symbol field-names))) - - (define ,copy-name copy) - - ,@(map (let ((ctr 1)) - (lambda (n type read-only) - (let ((val (if read-only - `(define ,(symbol fsname "-" n) - (lambda (arg) (arg ,ctr))) - `(define ,(symbol fsname "-" n) - (dilambda - (lambda (arg) (arg ,ctr)) - (lambda (arg val) (set! (arg ,ctr) val))))))) - (set! ctr (+ 1 ctr)) - val))) - field-names field-types field-read-onlys)))) - - -;; ============================================================ -;; Structures - -(defstruct rect (x 0.0) (y 0.0) (width 0.0) (height 0.0)) -(defstruct point (x 0.0) (y 0.0)) -(defstruct stage (width 0) (height 0) (generations 0) (final-state #f)) diff --git a/scripts/utils.scm b/scripts/utils.scm deleted file mode 100644 index 3348075..0000000 --- a/scripts/utils.scm +++ /dev/null @@ -1,8 +0,0 @@ -(define (is-point-inside-rect? point rect) - (cond ((not (point? point)) #f) - ((not (rect? rect)) #f) - (else (and (>= (point-x point) (rect-x rect)) - (>= (point-y point) (rect-y rect)) - (<= (point-x point) (+ (rect-x rect) (rect-width rect))) - (<= (point-y point) (+ (rect-y rect) (rect-height rect)))) - ))) |