diff options
Diffstat (limited to 'scripts')
| -rw-r--r-- | scripts/main.el | 3 | ||||
| -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, 435 insertions, 0 deletions
diff --git a/scripts/main.el b/scripts/main.el new file mode 100644 index 0000000..2c6c54d --- /dev/null +++ b/scripts/main.el @@ -0,0 +1,3 @@ +(defun draw () + (rq-draw-circle 50.0 50.0 40.0) + ) diff --git a/scripts/main.scm b/scripts/main.scm new file mode 100644 index 0000000..9db17fc --- /dev/null +++ b/scripts/main.scm @@ -0,0 +1,299 @@ +(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 new file mode 100644 index 0000000..e78e5b3 --- /dev/null +++ b/scripts/prompt.scm @@ -0,0 +1,45 @@ +(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 new file mode 100644 index 0000000..e69de29 --- /dev/null +++ b/scripts/stage.scm diff --git a/scripts/structs.scm b/scripts/structs.scm new file mode 100644 index 0000000..c3fa6ea --- /dev/null +++ b/scripts/structs.scm @@ -0,0 +1,80 @@ +;; ============================================================ +;; 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 new file mode 100644 index 0000000..3348075 --- /dev/null +++ b/scripts/utils.scm @@ -0,0 +1,8 @@ +(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)))) + ))) |