diff options
| -rw-r--r-- | Makefile | 7 | ||||
| -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 | ||||
| -rw-r--r-- | src/extended_environment.rs | 76 | ||||
| -rw-r--r-- | src/main.rs | 44 |
9 files changed, 552 insertions, 10 deletions
@@ -3,9 +3,12 @@ SHELL := /bin/bash TARGET := wasm32-unknown-unknown BINARY := target/$(TARGET)/release/slgj-2025.wasm -.PHONY: build serve +.PHONY: build run -build: +build-wasm: cargo build --target $(TARGET) --release; \ mkdir -p www; \ cp -f $(BINARY) www/slgj-2025.wasm + +run: + cargo run; \ 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)))) + ))) diff --git a/src/extended_environment.rs b/src/extended_environment.rs new file mode 100644 index 0000000..d13cc2b --- /dev/null +++ b/src/extended_environment.rs @@ -0,0 +1,76 @@ +use macroquad::prelude::*; +use std::{cell::RefCell, collections::HashMap, rc::Rc}; +use rust_lisp::model::{Env, FloatType, RuntimeError, Symbol, Value}; +use rust_lisp::utils::{require_arg, require_typed_arg}; + +pub type HashMapRc = Rc<RefCell<HashMap<Value, Value>>>; + +pub fn extend_environment(env: &Rc<RefCell<Env>>) { + env.borrow_mut().define( + Symbol::from("mq-draw-circle"), + Value::NativeFunc( + |_env, args| { + let x = require_typed_arg::<FloatType>("mq-draw-circle", &args, 0).unwrap(); + let y = require_typed_arg::<FloatType>("mq-draw-circle", &args, 1).unwrap(); + let radius = require_typed_arg::<FloatType>("mq-draw-circle", &args, 2).unwrap(); + let color = GREEN; + + draw_circle(x, y, radius, color); + return Ok(Value::NIL); + }) + ); + + + // Hashtable functions + // TODO: convert to elisp compatible hash table command + env.borrow_mut().define( + Symbol::from("make-hash-table"), + Value::NativeFunc(|_env, args| { + let chunks = args.chunks(2); + + let mut hash = HashMap::new(); + + for pair in chunks { + let key = pair.get(0).unwrap(); + let value = pair.get(1); + + if let Some(value) = value { + hash.insert(key.clone(), value.clone()); + } else { + return Err(RuntimeError { + msg: format!("Must pass an even number of arguments to 'hash', because they're used as key/value pairs; found extra argument {}", key) + }); + } + } + + Ok(Value::HashMap(Rc::new(RefCell::new(hash)))) + }), + ); + + env.borrow_mut().define( + Symbol::from("hash_get"), + Value::NativeFunc(|_env, args| { + let hash = require_typed_arg::<&HashMapRc>("hash_get", &args, 0)?; + let key = require_arg("hash_get", &args, 1)?; + + Ok(hash + .borrow() + .get(key) + .map(|v| v.clone()) + .unwrap_or(Value::NIL)) + }), + ); + + env.borrow_mut().define( + Symbol::from("hash_set"), + Value::NativeFunc(|_env, args| { + let hash = require_typed_arg::<&HashMapRc>("hash_set", &args, 0)?; + let key = require_arg("hash_set", &args, 1)?; + let value = require_arg("hash_set", &args, 2)?; + + hash.borrow_mut().insert(key.clone(), value.clone()); + + Ok(Value::HashMap(hash.clone())) + }), + ); +} diff --git a/src/main.rs b/src/main.rs index dbc60fb..62a3562 100644 --- a/src/main.rs +++ b/src/main.rs @@ -3,33 +3,61 @@ use macroquad::prelude::*; use std::{cell::RefCell, rc::Rc}; use rust_lisp::default_env; +use rust_lisp::lisp; use rust_lisp::parser::parse; use rust_lisp::interpreter::eval; +use rust_lisp::model::{Symbol, Value}; +mod extended_environment; #[macroquad::main("BasicShapes")] async fn main() { // create a base environment let env = Rc::new(RefCell::new(default_env())); + // define new methods + extended_environment::extend_environment(&env); + // parse into an iterator of syntax trees (one for each root) - let mut ast_iter = parse("(+ \"Hello \" \"world!\")"); - let first_expression = ast_iter.next().unwrap().unwrap(); + // let mut ast_iter = parse("(+ \"Hello \" \"world!\")"); + // let first_expression = ast_iter.next().unwrap().unwrap(); // evaluate - let evaluation_result = eval(env.clone(), &first_expression).unwrap(); + // let evaluation_result = eval(env.clone(), &first_expression).unwrap(); + // let mut ast_iter = parse("(test_draw)"); + // let first_expression = ast_iter.next().unwrap().unwrap(); + + // let first_expression = lisp! {(test_draw)}; + + // let mut inc = parse("(begin (set a 0) (+ a 1))"); + // let mut inc = parse("(begin (define a 0) (set a (+ a 1)))"); + // let inc_exp = inc.next().unwrap().unwrap(); + + // let inc_exp = lisp! { + // (begin (define a 0) (set a (+ a 1))) + // }; + // eval(env.clone(), &inc_exp).unwrap(); - // use result - println!("{}", &evaluation_result); + // let inc_exp = lisp! { + // (set a (+ a 1)) + // }; + + let gol_exp = parse(include_str!("../scripts/main.el")); + for exp in gol_exp { + eval(env.clone(), &exp.unwrap()).unwrap(); + } + + // let mut inc = parse("(set a (+ a 1))"); + // let inc_exp = inc.next().unwrap().unwrap(); loop { clear_background(RED); draw_line(40.0, 40.0, 100.0, 200.0, 15.0, BLUE); draw_rectangle(screen_width() / 2.0 - 60.0, 100.0, 120.0, 60.0, GREEN); - draw_circle(screen_width() - 30.0, screen_height() - 30.0, 15.0, YELLOW); - - draw_text(&format!("IT WORKS! {}!", &evaluation_result), 20.0, 20.0, 30.0, DARKGRAY); + eval(env.clone(), &first_expression).unwrap(); + let inc_eval = eval(env.clone(), &inc_exp).unwrap(); + draw_text(&format!("IT WORKS! {}!", &inc_eval), 20.0, 20.0, 30.0, DARKGRAY); next_frame().await } |